diff options
190 files changed, 3194 insertions, 2409 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 06a733be45..2a325f2d71 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -173,6 +173,8 @@ azure-pipelines.yml @coq/ci-maintainers /plugins/rtauto/ @PierreCorbineau # Secondary maintainer @herbelin +/user-contrib/Ltac2 @ppedrot + ########## Pretyper ########## /pretyping/ @mattam82 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index e811c116b6..f0e17909c1 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -169,7 +169,7 @@ People are generally happy to help and very reactive. ["Watching" this repository](https://github.com/coq/coq/subscription) can result in a very large number of notifications. We advise that if -you do, either [confifure your mailbox](https://blog.github.com/2017-07-18-managing-large-numbers-of-github-notifications/#prioritize-the-notifications-you-receive) +you do, either [configure your mailbox](https://blog.github.com/2017-07-18-managing-large-numbers-of-github-notifications/#prioritize-the-notifications-you-receive) to handle incoming notifications efficiently, or you read your notifications within a web browser. You can configure how you receive notifications in [your GitHub settings](https://github.com/settings/notifications), @@ -154,6 +154,8 @@ of the Coq Proof assistant during the indicated time: Matthias Puech (INRIA-Bologna, 2008-2011) Yann Régis-Gianas (INRIA-PPS then IRIF, 2009-now) Clément Renard (INRIA, 2001-2004) + Talia Ringer (University of Washington, 2019) + Andreas Lynge (Aarhus University, 2019) Claudio Sacerdoti Coen (INRIA, 2004-2005) Amokrane Saïbi (INRIA, 1993-1998) Vincent Semeria (2018) @@ -170,7 +172,6 @@ of the Coq Proof assistant during the indicated time: Nickolai Zeldovich (MIT 2014-2016) Théo Zimmermann (ORCID: https://orcid.org/0000-0002-3580-8806, INRIA-PPS then IRIF, 2015-now) - Talia Ringer (UW, 2019) *************************************************************************** INRIA refers to: diff --git a/Makefile.build b/Makefile.build index 147668187f..c76c14f2de 100644 --- a/Makefile.build +++ b/Makefile.build @@ -365,7 +365,7 @@ $(COQPP): $(COQPPCMO) coqpp/coqpp_main.ml ########################################################################### # Specific rules for Uint63 ########################################################################### -kernel/uint63.ml: kernel/write_uint63.ml kernel/uint63_x86.ml kernel/uint63_amd64.ml +kernel/uint63.ml: kernel/write_uint63.ml kernel/uint63_i386_31.ml kernel/uint63_amd64_63.ml $(SHOW)'WRITE $@' $(HIDE)(cd kernel && ocaml unix.cma $(shell basename $<)) diff --git a/checker/check.ml b/checker/check.ml index c5bc59e72a..903258daef 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -51,7 +51,7 @@ let pr_path sp = type compilation_unit_name = DirPath.t type seg_univ = Univ.ContextSet.t * bool -type seg_proofs = Constr.constr option array +type seg_proofs = (Opaqueproof.cooking_info list * int * Constr.constr option) array type library_t = { library_name : compilation_unit_name; @@ -98,9 +98,19 @@ let access_opaque_table dp i = with Not_found -> assert false in assert (i < Array.length t); - t.(i) + let (info, n, c) = t.(i) in + match c with + | None -> None + | Some c -> Some (Cooking.cook_constr info n c) -let () = Mod_checking.set_indirect_accessor access_opaque_table +let access_discharge = Cooking.cook_constr + +let indirect_accessor = { + Opaqueproof.access_proof = access_opaque_table; + Opaqueproof.access_discharge = access_discharge; +} + +let () = Mod_checking.set_indirect_accessor indirect_accessor let check_one_lib admit senv (dir,m) = let md = m.library_compiled in @@ -327,7 +337,6 @@ let intern_from_file ~intern_mode (dir, f) = let (sd:summary_disk), _, digest = marshal_in_segment f ch in let (md:library_disk), _, digest = marshal_in_segment f ch in let (opaque_csts:seg_univ option), _, udg = marshal_in_segment f ch in - let (discharging:'a option), _, _ = marshal_in_segment f ch in let (tasks:'a option), _, _ = marshal_in_segment f ch in let (table:seg_proofs option), pos, checksum = marshal_or_skip ~intern_mode f ch in @@ -340,7 +349,7 @@ let intern_from_file ~intern_mode (dir, f) = if dir <> sd.md_name then user_err ~hdr:"intern_from_file" (name_clash_message dir sd.md_name f); - if tasks <> None || discharging <> None then + if tasks <> None then user_err ~hdr:"intern_from_file" (str "The file "++str f++str " contains unfinished tasks"); if opaque_csts <> None then begin diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 1bc5891517..0684623a81 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -8,13 +8,13 @@ open Environ (** {6 Checking constants } *) -let get_proof = ref (fun _ _ -> assert false) -let set_indirect_accessor f = get_proof := f - -let indirect_accessor = { - Opaqueproof.access_proof = (fun dp n -> !get_proof dp n); +let indirect_accessor = ref { + Opaqueproof.access_proof = (fun _ _ -> assert false); + Opaqueproof.access_discharge = (fun _ _ _ -> assert false); } +let set_indirect_accessor f = indirect_accessor := f + let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ Constant.print kn); (* Locally set the oracle for further typechecking *) @@ -23,24 +23,24 @@ let check_constant_declaration env kn cb = (* [env'] contains De Bruijn universe variables *) let poly, env' = match cb.const_universes with - | Monomorphic ctx -> false, push_context_set ~strict:true ctx env + | Monomorphic ctx -> false, env | Polymorphic auctx -> let ctx = Univ.AUContext.repr auctx in let env = push_context ~strict:false ctx env in true, env in + let ty = cb.const_type in + let _ = infer_type env' ty in let env' = match cb.const_private_poly_univs, (cb.const_body, poly) with | None, _ -> env' | Some local, (OpaqueDef _, true) -> push_subgraph local env' | Some _, _ -> assert false in - let ty = cb.const_type in - let _ = infer_type env' ty in let otab = Environ.opaque_tables env in let body = match cb.const_body with | Undef _ | Primitive _ -> None | Def c -> Some (Mod_subst.force_constr c) - | OpaqueDef o -> Some (Opaqueproof.force_proof indirect_accessor otab o) + | OpaqueDef o -> Some (Opaqueproof.force_proof !indirect_accessor otab o) in let () = match body with diff --git a/checker/mod_checking.mli b/checker/mod_checking.mli index dbc81c8507..7aa1f837a0 100644 --- a/checker/mod_checking.mli +++ b/checker/mod_checking.mli @@ -8,6 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val set_indirect_accessor : (Names.DirPath.t -> int -> Constr.t option) -> unit +val set_indirect_accessor : Opaqueproof.indirect_accessor -> unit val check_module : Environ.env -> Names.ModPath.t -> Declarations.module_body -> unit diff --git a/checker/values.ml b/checker/values.ml index 031f05dd6b..4a4c8d803c 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -131,7 +131,7 @@ let v_proj = v_tuple "projection" [|v_proj_repr; v_bool|] let rec v_constr = Sum ("constr",0,[| [|Int|]; (* Rel *) - [|Fail "Var"|]; (* Var *) + [|v_id|]; (* Var *) [|Fail "Meta"|]; (* Meta *) [|Fail "Evar"|]; (* Evar *) [|v_sort|]; (* Sort *) @@ -383,6 +383,22 @@ let v_libsum = let v_lib = Tuple ("library",[|v_compiled_lib;v_libraryobjs|]) -let v_opaques = Array (Opt v_constr) +let v_ndecl = v_sum "named_declaration" 0 + [| [|v_binder_annot v_id; v_constr|]; (* LocalAssum *) + [|v_binder_annot v_id; v_constr; v_constr|] |] (* LocalDef *) + +let v_nctxt = List v_ndecl + +let v_work_list = + let v_abstr = v_pair v_instance (Array v_id) in + Tuple ("work_list", [|v_hmap v_cst v_abstr; v_hmap v_cst v_abstr|]) + +let v_abstract = + Tuple ("abstract", [| v_nctxt; v_instance; v_abs_context |]) + +let v_cooking_info = + Tuple ("cooking_info", [|v_work_list; v_abstract|]) + +let v_opaques = Array (Tuple ("opaque", [| List v_cooking_info; Int; Opt v_constr |])) let v_univopaques = Opt (Tuple ("univopaques",[|v_context_set;v_bool|])) 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 42fe13e4eb..d5aedfcbb1 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -357,22 +357,31 @@ 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" -> - fprintf fmt "let proof = (%a) ~pstate:st.Vernacstate.proof in { st with Vernacstate.proof }" 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 = - fprintf fmt "@[(%afun %a~atts@ ~st@ -> coqpp_body %a%a ~st)@]" - print_body_fun r print_binders r.vernac_toks +let understand_state = function + | "close_proof" -> "VtCloseProof", false + | "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 "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 "Vernacextend.%s (%s%a)" state (if unit_wrap then "fun () ->" else "") + print_code r.vernac_body + +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_state state) r + +let print_body state fmt r = + 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 let rec print_sig fmt = function @@ -383,12 +392,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 "" @@ -407,7 +416,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..128e02e85f 100644 --- a/coqpp/coqpp_parse.mly +++ b/coqpp/coqpp_parse.mly @@ -64,7 +64,7 @@ let parse_user_entry s sep = %token <int> 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 } @@ -270,7 +273,7 @@ tactic_level: ; tactic_rules: -| tactic_rule { [$1] } +| { [] } | tactic_rule tactic_rules { $1 :: $2 } ; diff --git a/dev/base_include b/dev/base_include index b214959bad..f764eaf4f5 100644 --- a/dev/base_include +++ b/dev/base_include @@ -185,7 +185,7 @@ open Declareops;; let constbody_of_string s = let b = Global.lookup_constant (Nametab.locate_constant (qualid_of_string s)) in - Option.get (Global.body_of_constant_body b);; + Option.get (Global.body_of_constant_body Library.indirect_accessor b);; (* Get the current goal *) (* diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 95fceb773a..fa39b41565 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -215,7 +215,7 @@ ######################################################################## # simple-io ######################################################################## -: "${simple_io_CI_REF:=dev}" +: "${simple_io_CI_REF:=master}" : "${simple_io_CI_GITURL:=https://github.com/Lysxia/coq-simple-io}" : "${simple_io_CI_ARCHIVEURL:=${simple_io_CI_GITURL}/archive}" diff --git a/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh b/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh deleted file mode 100644 index 2b4c1489ad..0000000000 --- a/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh +++ /dev/null @@ -1,13 +0,0 @@ -_OVERLAY_BRANCH=ho-matching-occ-sel - -if [ "$CI_PULL_REQUEST" = "7819" ] || [ "$CI_BRANCH" = "$_OVERLAY_BRANCH" ]; then - - unicoq_CI_REF="PR7819-overlay" - - mtac2_CI_REF="PR7819-overlay" - mtac2_CI_GITURL=https://github.com/mattam82/Mtac2 - - equations_CI_GITURL=https://github.com/mattam82/Coq-Equations - equations_CI_REF="PR7819-overlay" - -fi diff --git a/dev/ci/user-overlays/08764-validsdp-master-parsing-decimal.sh b/dev/ci/user-overlays/08764-validsdp-master-parsing-decimal.sh deleted file mode 100644 index 67f6f8610a..0000000000 --- a/dev/ci/user-overlays/08764-validsdp-master-parsing-decimal.sh +++ /dev/null @@ -1,18 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8764" ] || [ "$CI_BRANCH" = "master-parsing-decimal" ]; then - - ltac2_CI_REF=master-parsing-decimal - ltac2_CI_GITURL=https://github.com/proux01/ltac2 - - quickchick_CI_REF=master-parsing-decimal - quickchick_CI_GITURL=https://github.com/proux01/QuickChick - - Corn_CI_REF=master-parsing-decimal - Corn_CI_GITURL=https://github.com/proux01/corn - - HoTT_CI_REF=master-parsing-decimal - HoTT_CI_GITURL=https://github.com/proux01/HoTT - - stdlib2_CI_REF=master-parsing-decimal - stdlib2_CI_GITURL=https://github.com/proux01/stdlib2 - -fi diff --git a/dev/ci/user-overlays/08817-sprop.sh b/dev/ci/user-overlays/08817-sprop.sh deleted file mode 100644 index 81e18226ed..0000000000 --- a/dev/ci/user-overlays/08817-sprop.sh +++ /dev/null @@ -1,34 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8817" ] || [ "$CI_BRANCH" = "sprop" ]; then - aac_tactics_CI_REF=sprop - aac_tactics_CI_GITURL=https://github.com/SkySkimmer/aac-tactics - - coq_dpdgraph_CI_REF=sprop - coq_dpdgraph_CI_GITURL=https://github.com/SkySkimmer/coq-dpdgraph - - coqhammer_CI_REF=sprop - coqhammer_CI_GITURL=https://github.com/SkySkimmer/coqhammer - - elpi_CI_REF=sprop - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - - equations_CI_REF=sprop - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - ltac2_CI_REF=sprop - ltac2_CI_GITURL=https://github.com/SkySkimmer/ltac2 - - unicoq_CI_REF=sprop - unicoq_CI_GITURL=https://github.com/SkySkimmer/unicoq - - mtac2_CI_REF=sprop - mtac2_CI_GITURL=https://github.com/SkySkimmer/mtac2 - - paramcoq_CI_REF=sprop - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq - - quickchick_CI_REF=sprop - quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick - - relation_algebra_CI_REF=sprop - relation_algebra_CI_GITURL=https://github.com/SkySkimmer/relation-algebra -fi diff --git a/dev/ci/user-overlays/08829-proj-syntax-check.sh b/dev/ci/user-overlays/08829-proj-syntax-check.sh deleted file mode 100644 index c04621114f..0000000000 --- a/dev/ci/user-overlays/08829-proj-syntax-check.sh +++ /dev/null @@ -1,5 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8829" ] || [ "$CI_BRANCH" = "proj-syntax-check" ]; then - lambdaRust_CI_REF=proj-syntax-check - lambdaRust_CI_GITURL=https://github.com/SkySkimmer/lambda-rust - lambdaRust_CI_ARCHIVEURL=$lambdaRust_CI_GITURL/archive -fi diff --git a/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh b/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh deleted file mode 100644 index dc39ea5ef0..0000000000 --- a/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh +++ /dev/null @@ -1,7 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8893" ] || [ "$CI_BRANCH" = "master+moving-evars-of-term-on-econstr" ]; then - - equations_CI_BRANCH=master+fix-evars_of_term-pr8893 - equations_CI_REF=master+fix-evars_of_term-pr8893 - equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08984-vbgl-rm-hardwired-hint-db.sh b/dev/ci/user-overlays/08984-vbgl-rm-hardwired-hint-db.sh deleted file mode 100644 index 12be1b676a..0000000000 --- a/dev/ci/user-overlays/08984-vbgl-rm-hardwired-hint-db.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8984" ] || [ "$CI_BRANCH" = "rm-hardwired-hint-db" ]; then - - HoTT_CI_REF=rm-hardwired-hint-db - HoTT_CI_GITURL=https://github.com/vbgl/HoTT - - ltac2_CI_REF=rm-hardwired-hint-db - ltac2_CI_GITURL=https://github.com/vbgl/ltac2 - - UniMath_CI_REF=rm-hardwired-hint-db - UniMath_CI_GITURL=https://github.com/vbgl/UniMath - -fi diff --git a/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh b/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh deleted file mode 100644 index c09d1b8929..0000000000 --- a/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh +++ /dev/null @@ -1,30 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9129" ] || [ "$CI_BRANCH" = "proof+no_global_partial" ]; then - - aac_tactics_CI_REF=proof+no_global_partial - aac_tactics_CI_GITURL=https://github.com/ejgallego/aac-tactics - - # coqhammer_CI_REF=proof+no_global_partial - # coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer - - elpi_CI_REF=proof+no_global_partial - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - equations_CI_REF=proof+no_global_partial - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - ltac2_CI_REF=proof+no_global_partial - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - - # unicoq_CI_REF=proof+no_global_partial - # unicoq_CI_GITURL=https://github.com/ejgallego/unicoq - - mtac2_CI_REF=proof+no_global_partial - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - - paramcoq_CI_REF=proof+no_global_partial - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - - quickchick_CI_REF=proof+no_global_partial - quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick - -fi diff --git a/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh b/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh deleted file mode 100644 index 1e1d36d54a..0000000000 --- a/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9165" ] || [ "$CI_BRANCH" = "recarg-cleanup" ]; then - - elpi_CI_REF=recarg-cleanup - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - quickchick_CI_REF=recarg-cleanup - quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick - -fi diff --git a/dev/ci/user-overlays/09173-ejgallego-proofview+proof_info.sh b/dev/ci/user-overlays/09173-ejgallego-proofview+proof_info.sh deleted file mode 100644 index 23eb24c304..0000000000 --- a/dev/ci/user-overlays/09173-ejgallego-proofview+proof_info.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9173" ] || [ "$CI_BRANCH" = "proofview+proof_info" ]; then - - ltac2_CI_REF=proofview+proof_info - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - - fiat_parsers_CI_REF=proofview+proof_info - fiat_parsers_CI_GITURL=https://github.com/ejgallego/fiat - -fi diff --git a/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh b/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh deleted file mode 100644 index 1110157069..0000000000 --- a/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9389" ] || [ "$CI_BRANCH" = "set-implicits" ]; then - - equations_CI_REF=set-implicits - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - mtac2_CI_REF=set-implicits - mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 - -fi diff --git a/dev/ci/user-overlays/09439-sep-variance.sh b/dev/ci/user-overlays/09439-sep-variance.sh deleted file mode 100644 index cca85a2f68..0000000000 --- a/dev/ci/user-overlays/09439-sep-variance.sh +++ /dev/null @@ -1,14 +0,0 @@ - -if [ "$CI_PULL_REQUEST" = "9439" ] || [ "$CI_BRANCH" = "sep-variance" ]; then - elpi_CI_REF=sep-variance - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - - equations_CI_REF=sep-variance - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - mtac2_CI_REF=sep-variance - mtac2_CI_GITURL=https://github.com/SkySkimmer/mtac2 - - paramcoq_CI_REF=sep-variance - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq -fi diff --git a/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh b/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh deleted file mode 100644 index 1af8b5430d..0000000000 --- a/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9476" ] || [ "$CI_BRANCH" = "context-constructor" ]; then - - quickchick_CI_REF=context-constructor - quickchick_CI_GITURL=https://github.com/ppedrot/QuickChick - - equations_CI_REF=context-constructor - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/09567-ejgallego-hooks_unify.sh b/dev/ci/user-overlays/09567-ejgallego-hooks_unify.sh deleted file mode 100644 index 27ce9aca16..0000000000 --- a/dev/ci/user-overlays/09567-ejgallego-hooks_unify.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9567" ] || [ "$CI_BRANCH" = "hooks_unify" ]; then - - equations_CI_REF=hooks_unify - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - mtac2_CI_REF=hooks_unify - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - - paramcoq_CI_REF=hooks_unify - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - -fi diff --git a/dev/ci/user-overlays/09602-gares-more-delta-in-termination-checking.sh b/dev/ci/user-overlays/09602-gares-more-delta-in-termination-checking.sh deleted file mode 100644 index 18a295cdbb..0000000000 --- a/dev/ci/user-overlays/09602-gares-more-delta-in-termination-checking.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9602" ] || [ "$CI_BRANCH" = "more-delta-in-termination-checking" ]; then - - equations_CI_REF=more-delta-in-termination-checking - equations_CI_GITURL=https://github.com/gares/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/09678-printed-by-env.sh b/dev/ci/user-overlays/09678-printed-by-env.sh deleted file mode 100644 index ccb3498764..0000000000 --- a/dev/ci/user-overlays/09678-printed-by-env.sh +++ /dev/null @@ -1,14 +0,0 @@ - -if [ "$CI_PULL_REQUEST" = "9678" ] || [ "$CI_BRANCH" = "printed-by-env" ]; then - elpi_CI_REF=printed-by-env - elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi - - equations_CI_REF=printed-by-env - equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - - ltac2_CI_REF=printed-by-env - ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 - - quickchick_CI_REF=printed-by-env - quickchick_CI_GITURL=https://github.com/maximedenes/QuickChick -fi diff --git a/dev/ci/user-overlays/09733-gares-quotations.sh b/dev/ci/user-overlays/09733-gares-quotations.sh deleted file mode 100644 index b17454fc4c..0000000000 --- a/dev/ci/user-overlays/09733-gares-quotations.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9733" ] || [ "$CI_BRANCH" = "quotations" ]; then - - ltac2_CI_REF=quotations - ltac2_CI_GITURL=https://github.com/gares/ltac2 - -fi diff --git a/dev/ci/user-overlays/09815-token-type.sh b/dev/ci/user-overlays/09815-token-type.sh deleted file mode 100644 index 4b49011de3..0000000000 --- a/dev/ci/user-overlays/09815-token-type.sh +++ /dev/null @@ -1,4 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9815" ] || [ "$CI_BRANCH" = "token-type" ]; then - ltac2_CI_REF=token-type - ltac2_CI_GITURL=https://github.com/proux01/ltac2 -fi diff --git a/dev/ci/user-overlays/09870-vbgl-recordops.sh b/dev/ci/user-overlays/09870-vbgl-recordops.sh deleted file mode 100644 index bb14a8c204..0000000000 --- a/dev/ci/user-overlays/09870-vbgl-recordops.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9870" ] || [ "$CI_BRANCH" = "doc-canonical" ]; then - - elpi_CI_REF=pr-9870 - elpi_CI_GITURL=https://github.com/vbgl/coq-elpi - -fi diff --git a/dev/ci/user-overlays/09895-ejgallego-require+upper.sh b/dev/ci/user-overlays/09895-ejgallego-require+upper.sh deleted file mode 100644 index 9a42c829ce..0000000000 --- a/dev/ci/user-overlays/09895-ejgallego-require+upper.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9895" ] || [ "$CI_BRANCH" = "require+upper" ]; then - - quickchick_CI_REF=require+upper - quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick - -fi diff --git a/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh b/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh deleted file mode 100644 index 01d3068591..0000000000 --- a/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh +++ /dev/null @@ -1,21 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9909" ] || [ "$CI_BRANCH" = "pretyping-rm-global" ]; then - - elpi_CI_REF=pretyping-rm-global - elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi - - coqhammer_CI_REF=pretyping-rm-global - coqhammer_CI_GITURL=https://github.com/maximedenes/coqhammer - - equations_CI_REF=pretyping-rm-global - equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - - ltac2_CI_REF=pretyping-rm-global - ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 - - paramcoq_CI_REF=pretyping-rm-global - paramcoq_CI_GITURL=https://github.com/maximedenes/paramcoq - - mtac2_CI_REF=pretyping-rm-global - mtac2_CI_GITURL=https://github.com/maximedenes/Mtac2 - -fi diff --git a/dev/ci/user-overlays/09973-gares-elpi-2.1.sh b/dev/ci/user-overlays/09973-gares-elpi-2.1.sh deleted file mode 100644 index 9a6e25d893..0000000000 --- a/dev/ci/user-overlays/09973-gares-elpi-2.1.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9973" ] || [ "$CI_BRANCH" = "elpi-1.2" ]; then - - elpi_CI_REF=overlay-elpi1.2-coq-master - elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh b/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh deleted file mode 100644 index 9f9cc19e83..0000000000 --- a/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10052" ] || [ "$CI_BRANCH" = "cleanup-logic-convert-hyp" ]; then - - relation_algebra_CI_REF=cleanup-logic-convert-hyp - relation_algebra_CI_GITURL=https://github.com/ppedrot/relation-algebra - -fi diff --git a/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh b/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh deleted file mode 100644 index 0e1449f36c..0000000000 --- a/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10069" ] || [ "$CI_BRANCH" = "whd-for-evar-conv-no-stack" ]; then - - unicoq_CI_REF=whd-for-evar-conv-no-stack - unicoq_CI_GITURL=https://github.com/ppedrot/unicoq - -fi diff --git a/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh b/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh deleted file mode 100644 index 2015935dd9..0000000000 --- a/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10076" ] || [ "$CI_BRANCH" = "canonical-disable-hint" ]; then - - elpi_CI_REF=canonical-disable-hint - elpi_CI_GITURL=https://github.com/vbgl/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh b/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh deleted file mode 100644 index 4032b1c6b5..0000000000 --- a/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10125" ] || [ "$CI_BRANCH" = "run_tactic_gen" ]; then - - paramcoq_CI_REF=run_tactic_gen - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq - -fi diff --git a/dev/ci/user-overlays/10133-SkySkimmer-kelim.sh b/dev/ci/user-overlays/10133-SkySkimmer-kelim.sh deleted file mode 100644 index 3658e96a3a..0000000000 --- a/dev/ci/user-overlays/10133-SkySkimmer-kelim.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10133" ] || [ "$CI_BRANCH" = "kelim" ]; then - - equations_CI_REF=kelim - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh b/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh deleted file mode 100644 index bc8aa33565..0000000000 --- a/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10135" ] || [ "$CI_BRANCH" = "detype-anonymous" ]; then - - unicoq_CI_REF=detype-anonymous - unicoq_CI_GITURL=https://github.com/maximedenes/unicoq - -fi diff --git a/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh b/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh deleted file mode 100644 index fcbeb32a58..0000000000 --- a/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10188" ] || [ "$CI_BRANCH" = "def-not-visible-remove-warning" ]; then - - elpi_CI_REF=def-not-visible-generic-warning - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10177-SkySkimmer-generalize.sh b/dev/ci/user-overlays/10177-SkySkimmer-generalize.sh deleted file mode 100644 index a89f6aca1b..0000000000 --- a/dev/ci/user-overlays/10177-SkySkimmer-generalize.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10177" ] || [ "$CI_BRANCH" = "generalize" ]; then - - quickchick_CI_REF=generalize - quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick - -fi diff --git a/dev/ci/user-overlays/10201-ppedrot-opaque-future-cleanup.sh b/dev/ci/user-overlays/10201-ppedrot-opaque-future-cleanup.sh deleted file mode 100644 index e3bbb84bcb..0000000000 --- a/dev/ci/user-overlays/10201-ppedrot-opaque-future-cleanup.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10201" ] || [ "$CI_BRANCH" = "opaque-future-cleanup" ]; then - - coq_dpdgraph_CI_REF=opaque-future-cleanup - coq_dpdgraph_CI_GITURL=https://github.com/ppedrot/coq-dpdgraph - - coqhammer_CI_REF=opaque-future-cleanup - coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer - - elpi_CI_REF=opaque-future-cleanup - elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi - - paramcoq_CI_REF=opaque-future-cleanup - paramcoq_CI_GITURL=https://github.com/ppedrot/paramcoq - -fi diff --git a/dev/ci/user-overlays/README.md b/dev/ci/user-overlays/README.md index 7fb73e447d..4c2f264a74 100644 --- a/dev/ci/user-overlays/README.md +++ b/dev/ci/user-overlays/README.md @@ -21,14 +21,14 @@ The name of your overlay file should start with a five-digit pull request number, followed by a dash, anything (for instance your GitHub nickname and the branch name), then a `.sh` extension (`[0-9]{5}-[a-zA-Z0-9-_]+.sh`). -Example: `00669-maximedenes-ssr-merge.sh` containing +Example: `10185-SkySkimmer-instance-no-bang.sh` containing ``` -#!/bin/sh +if [ "$CI_PULL_REQUEST" = "10185" ] || [ "$CI_BRANCH" = "instance-no-bang" ]; then + + quickchick_CI_REF=instance-no-bang + quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick -if [ "$CI_PULL_REQUEST" = "669" ] || [ "$CI_BRANCH" = "ssr-merge" ]; then - mathcomp_CI_REF=ssr-merge - mathcomp_CI_GITURL=https://github.com/maximedenes/math-comp fi ``` diff --git a/dev/tools/coqdev.el b/dev/tools/coqdev.el index b89ae67a82..5f9f326750 100644 --- a/dev/tools/coqdev.el +++ b/dev/tools/coqdev.el @@ -78,11 +78,7 @@ Specifically `camldebug-command-name' and `ocamldebug-command-name'." Note that this function is executed before _Coqproject is read if it exists." (let ((dir (coqdev-default-directory))) (when dir - (unless coq-prog-args - (setq coq-prog-args - `("-coqlib" ,dir - "-topfile" ,buffer-file-name))) - (setq-local coq-prog-name (concat dir "bin/coqtop"))))) + (setq-local coq-prog-name (concat dir "_build/default/dev/shim/coqtop-prelude"))))) (add-hook 'hack-local-variables-hook #'coqdev-setup-proofgeneral) (defvar coqdev-ocamldebug-command "dune exec dev/dune-dbg" diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 2859b56cbe..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 ~st = in_current_context econstr_display c; st 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 ~st = in_current_context print_pure_econstr c; st 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/dev/v8-syntax/syntax-v8.tex b/dev/v8-syntax/syntax-v8.tex index dd3908c25f..601d52ddda 100644 --- a/dev/v8-syntax/syntax-v8.tex +++ b/dev/v8-syntax/syntax-v8.tex @@ -1167,7 +1167,6 @@ $$ \nlsep \TERM{Show}~\OPT{\NT{num}} \nlsep \TERM{Show}~\TERM{Implicit}~\TERM{Arguments}~\OPT{\NT{num}} \nlsep \TERM{Show}~\TERM{Node} -\nlsep \TERM{Show}~\TERM{Script} \nlsep \TERM{Show}~\TERM{Existentials} \nlsep \TERM{Show}~\TERM{Tree} \nlsep \TERM{Show}~\TERM{Conjecture} diff --git a/doc/changelog/02-specification-language/10049-bidi-app.rst b/doc/changelog/02-specification-language/10049-bidi-app.rst new file mode 100644 index 0000000000..79678c5242 --- /dev/null +++ b/doc/changelog/02-specification-language/10049-bidi-app.rst @@ -0,0 +1,6 @@ +- New annotation in `Arguments` for bidirectionality hints: it is now possible + to tell type inference to use type information from the context once the `n` + first arguments of an application are known. The syntax is: + `Arguments foo x y & z`. + `#10049 <https://github.com/coq/coq/pull/10049>`_, by Maxime Dénès with + help from Enrico Tassi 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..21ec7f8e5b --- /dev/null +++ b/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst @@ -0,0 +1,11 @@ +- Function always opens a proof when used with a ``measure`` or ``wf`` + annotation, see :ref:`advanced-recursive-functions` for the updated + documentation (`#10215 <https://github.com/coq/coq/pull/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 <https://github.com/coq/coq/pull/10215>`_, + by Enrico Tassi). diff --git a/doc/changelog/04-tactics/10205-discriminate-HoTT.rst b/doc/changelog/04-tactics/10205-discriminate-HoTT.rst new file mode 100644 index 0000000000..bb2d2a092e --- /dev/null +++ b/doc/changelog/04-tactics/10205-discriminate-HoTT.rst @@ -0,0 +1,6 @@ +- Make the :tacn:`discriminate` tactic work together with + :flag:`Universe Polymorphism` and equality in :g:`Type`. This, + in particular, makes :tacn:`discriminate` compatible with the HoTT + library https://github.com/HoTT/HoTT. + (`#10205 <https://github.com/coq/coq/pull/10205>`_, + by Andreas Lynge, review by Pierre-Marie Pédrot and Matthieu Sozeau) diff --git a/doc/changelog/05-tactic-language/10002-ltac2.rst b/doc/changelog/05-tactic-language/10002-ltac2.rst new file mode 100644 index 0000000000..6d62f11eff --- /dev/null +++ b/doc/changelog/05-tactic-language/10002-ltac2.rst @@ -0,0 +1,9 @@ +- Ltac2, a new version of the tactic language Ltac, that doesn't + preserve backward compatibility, has been integrated in the main Coq + distribution. It is still experimental, but we already recommend + users of advanced Ltac to start using it and report bugs or request + enhancements. See its documentation in the :ref:`dedicated chapter + <ltac2>` (`#10002 <https://github.com/coq/coq/pull/10002>`_, plugin + authored by Pierre-Marie Pédrot, with contributions by various + users, integration by Maxime Dénès, help on integrating / improving + the documentation by Théo Zimmermann and Jim Fehrle). diff --git a/doc/changelog/05-tactic-language/10289-ltac2+delimited-constr-in-notations.rst b/doc/changelog/05-tactic-language/10289-ltac2+delimited-constr-in-notations.rst new file mode 100644 index 0000000000..bd1c0c42e8 --- /dev/null +++ b/doc/changelog/05-tactic-language/10289-ltac2+delimited-constr-in-notations.rst @@ -0,0 +1,5 @@ +- Ltac2 tactic notations with “constr” arguments can specify the + interpretation scope for these arguments; + see :ref:`ltac2_notations` for details + (`#10289 <https://github.com/coq/coq/pull/10289>`_, + by Vincent Laporte). diff --git a/doc/changelog/07-commands-and-options/10277-no-show-script.rst b/doc/changelog/07-commands-and-options/10277-no-show-script.rst new file mode 100644 index 0000000000..7fdeb632b4 --- /dev/null +++ b/doc/changelog/07-commands-and-options/10277-no-show-script.rst @@ -0,0 +1,2 @@ +- Remove ``Show Script`` command (deprecated since 8.10) + (`#10277 <https://github.com/coq/coq/pull/10277>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/12-misc/10019-PG-proof-diffs.rst b/doc/changelog/12-misc/10019-PG-proof-diffs.rst new file mode 100644 index 0000000000..b2d191be26 --- /dev/null +++ b/doc/changelog/12-misc/10019-PG-proof-diffs.rst @@ -0,0 +1,3 @@ +- Proof General can now display Coq-generated diffs between proof steps + in color. (`#10019 <https://github.com/coq/coq/pull/10019>`_ and (in Proof General) + `#421 <https://github.com/ProofGeneral/PG/pull/421>`_, by Jim Fehrle). diff --git a/doc/plugin_tutorial/README.md b/doc/plugin_tutorial/README.md index f82edb2352..6d142a9af8 100644 --- a/doc/plugin_tutorial/README.md +++ b/doc/plugin_tutorial/README.md @@ -1,34 +1,20 @@ How to write plugins in Coq =========================== - # Working environment : merlin, tuareg (open question) + # Working environment + + In addition to installing OCaml and Coq, it can help to install several tools for development. - ## OCaml & related tools + ## Merlin These instructions use [OPAM](http://opam.ocaml.org/doc/Install.html) ```shell -opam init --root=$PWD/CIW2018 --compiler=4.06.0 -j2 -eval `opam config env --root=$PWD/CIW2018` -opam install camlp5 ocamlfind num # Coq's dependencies -opam install lablgtk # Coqide's dependencies (optional) opam install merlin # prints instructions for vim and emacs ``` - ## Coq - -```shell -git clone git@github.com:coq/coq.git -cd coq -./configure -profile devel -make -j2 -cd .. -export PATH=$PWD/coq/bin:$PATH -``` - ## This tutorial ```shell -git clone git@github.com:ybertot/plugin_tutorials.git cd plugin_tutorials/tuto0 make .merlin # run before opening .ml files in your editor make # build @@ -40,6 +26,8 @@ make # build package a ml4 file in a plugin, organize a `Makefile`, `_CoqProject` - Example of syntax to add a new toplevel command - Example of function call to print a simple message + - Example of function call to print a simple warning + - Example of function call to raise a simple error to the user - Example of syntax to add a simple tactic (that does nothing and prints a message) - To use it: @@ -54,19 +42,23 @@ make # build Require Import Tuto0.Loader. HelloWorld. ``` - # tuto1 : Ocaml to Coq communication + You can also modify and run `theories/Demo.v`. + + # tuto1 : OCaml to Coq communication Explore the memory of Coq, modify it - - Commands that take arguments: strings, symbols, expressions of the calculus of constructions + - Commands that take arguments: strings, integers, symbols, expressions of the calculus of constructions + - Examples of using environments correctly + - Examples of using state (the evar_map) correctly - Commands that interact with type-checking in Coq + - A command that checks convertibility between two terms - A command that adds a new definition or theorem - - A command that uses a name and exploits the existing definitions - or theorems + - A command that uses a name and exploits the existing definitions or theorems - A command that exploits an existing ongoing proof - A command that defines a new tactic Compilation and loading must be performed as for `tuto0`. - # tuto2 : Ocaml to Coq communication + # tuto2 : OCaml to Coq communication A more step by step introduction to writing commands - Explanation of the syntax of entries - Adding a new type to and parsing to the available choices diff --git a/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg b/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg index 5c633fe862..97689adfed 100644 --- a/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg +++ b/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg @@ -5,14 +5,70 @@ DECLARE PLUGIN "tuto0_plugin" open Pp open Ltac_plugin +let tuto_warn = CWarnings.create ~name:"name" ~category:"category" + (fun _ -> strbrk Tuto0_main.message) + } +(*** Printing messages ***) + +(* + * This defines a command that prints HelloWorld. + * Note that Feedback.msg_notice can be used to print messages. + *) VERNAC COMMAND EXTEND HelloWorld CLASSIFIED AS QUERY | [ "HelloWorld" ] -> { Feedback.msg_notice (strbrk Tuto0_main.message) } END +(* + * This is a tactic version of the same thing. + *) TACTIC EXTEND hello_world_tactic | [ "hello_world" ] -> { let _ = Feedback.msg_notice (str Tuto0_main.message) in Tacticals.New.tclIDTAC } END + +(*** Printing warnings ***) + +(* + * This defines a command that prints HelloWorld as a warning. + * tuto_warn is defined at the top-level, before the command runs, + * which is standard. + *) +VERNAC COMMAND EXTEND HelloWarning CLASSIFIED AS QUERY +| [ "HelloWarning" ] -> + { + tuto_warn () + } +END + +(* + * This is a tactic version of the same thing. + *) +TACTIC EXTEND hello_warning_tactic +| [ "hello_warning" ] -> + { + let _ = tuto_warn () in + Tacticals.New.tclIDTAC + } +END + +(*** Printing errors ***) + +(* + * This defines a command that prints HelloWorld inside of an error. + * Note that CErrors.user_err can be used to raise errors to the user. + *) +VERNAC COMMAND EXTEND HelloError CLASSIFIED AS QUERY +| [ "HelloError" ] -> { CErrors.user_err (str Tuto0_main.message) } +END + +(* + * This is a tactic version of the same thing. + *) +TACTIC EXTEND hello_error_tactic +| [ "hello_error" ] -> + { let _ = CErrors.user_err (str Tuto0_main.message) in + Tacticals.New.tclIDTAC } +END diff --git a/doc/plugin_tutorial/tuto0/theories/Demo.v b/doc/plugin_tutorial/tuto0/theories/Demo.v index bdc61986af..54d5239421 100644 --- a/doc/plugin_tutorial/tuto0/theories/Demo.v +++ b/doc/plugin_tutorial/tuto0/theories/Demo.v @@ -1,8 +1,28 @@ From Tuto0 Require Import Loader. +(*** Printing messages ***) + HelloWorld. Lemma test : True. Proof. hello_world. Abort. + +(*** Printing warnings ***) + +HelloWarning. + +Lemma test : True. +Proof. +hello_warning. +Abort. + +(*** Signaling errors ***) + +Fail HelloError. + +Lemma test : True. +Proof. +Fail hello_error. +Abort. diff --git a/doc/plugin_tutorial/tuto1/_CoqProject b/doc/plugin_tutorial/tuto1/_CoqProject index 585d1360be..60f9f0a0c7 100644 --- a/doc/plugin_tutorial/tuto1/_CoqProject +++ b/doc/plugin_tutorial/tuto1/_CoqProject @@ -2,7 +2,10 @@ -I src theories/Loader.v +theories/Demo.v +src/inspector.mli +src/inspector.ml src/simple_check.mli src/simple_check.ml src/simple_declare.mli diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 1d0aca1caf..0b005a2341 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -8,7 +8,6 @@ DECLARE PLUGIN "tuto1_plugin" theories/Loader.v *) open Ltac_plugin -open Attributes open Pp (* This module defines the types of arguments to be used in the EXTEND directives below, for example the string one. *) @@ -16,141 +15,280 @@ open Stdarg } -VERNAC COMMAND EXTEND HelloWorld CLASSIFIED AS QUERY -| [ "Hello" string(s) ] -> - { Feedback.msg_notice (strbrk "Hello " ++ str s) } -END +(*** Printing inputs ***) -(* reference is allowed as a syntactic entry, but so are all the entries - found the signature of module Prim in file coq/parsing/pcoq.mli *) +(* + * This command prints an input from the user. + * + * A list with allowable inputs can be found in interp/stdarg.mli, + * plugin/ltac/extraargs.mli, and plugin/ssr/ssrparser.mli + * (remove the wit_ prefix), but not all of these are allowable + * (unit and bool, for example, are not usable from within here). + * + * We include only some examples that are standard and useful for commands. + * Some of the omitted examples are useful for tactics. + * + * Inspector is our own file that defines a simple messaging function. + * The printing functions (pr_qualid and so on) are in printing. + * + * Some of these cases would be ambiguous if we used "What's" for each of + * these. For example, all of these are terms. We purposely disambiguate. + *) +VERNAC COMMAND EXTEND WhatIsThis CLASSIFIED AS QUERY +| [ "What's" constr(e) ] -> + { + let env = Global.env () in (* we'll explain later *) + let sigma = Evd.from_env env in (* we'll explain later *) + Inspector.print_input e (Ppconstr.pr_constr_expr env sigma) "term" + } +| [ "What" "kind" "of" "term" "is" string(s) ] -> + { Inspector.print_input s strbrk "string" } +| [ "What" "kind" "of" "term" "is" int(i) ] -> + { Inspector.print_input i Pp.int "int" } +| [ "What" "kind" "of" "term" "is" ident(id) ] -> + { Inspector.print_input id Ppconstr.pr_id "identifier" } +| [ "What" "kind" "of" "identifier" "is" reference(r) ] -> + { Inspector.print_input r Ppconstr.pr_qualid "reference" } +END -VERNAC COMMAND EXTEND HelloAgain CLASSIFIED AS QUERY -| [ "HelloAgain" reference(r)] -> -(* The function Ppconstr.pr_qualid was found by searching all mli files - for a function of type qualid -> Pp.t *) - { Feedback.msg_notice - (strbrk "Hello again " ++ Ppconstr.pr_qualid r)} +(* + * This command demonstrates basic combinators built into the DSL here. + * You can generalize this for constr_list, constr_opt, int_list, and so on. + *) +VERNAC COMMAND EXTEND WhatAreThese CLASSIFIED AS QUERY +| [ "What" "is" int_list(l) "a" "list" "of" ] -> + { + let print l = str "[" ++ Pp.prlist_with_sep (fun () -> str ";") Pp.int l ++ str "]" in + Inspector.print_input l print "int list" + } +| [ "Is" ne_int_list(l) "nonempty" ] -> + { + let print l = str "[" ++ Pp.prlist_with_sep (fun () -> str ";") Pp.int l ++ str "]" in + Inspector.print_input l print "nonempty int list" + } +| [ "And" "is" int_opt(o) "provided" ] -> + { + let print o = strbrk (if Option.has_some o then "Yes" else "No") in + Feedback.msg_notice (print o) + } END -(* According to parsing/pcoq.mli, e has type constr_expr *) -(* this type is defined in pretyping/constrexpr.ml *) -(* Question for the developers: why is the file constrexpr.ml and not - constrexpr.mli --> Easier for packing the software in components. *) -VERNAC COMMAND EXTEND TakingConstr CLASSIFIED AS QUERY -| [ "Cmd1" constr(e) ] -> - { let _ = e in Feedback.msg_notice (strbrk "Cmd1 parsed something") } + +(*** Interning terms ***) + +(* + * The next step is to make something of parsed expression. + * Interesting information in interp/constrintern.mli. + * + * When you read in constr(e), e will have type Constrexpr.constr_expr, + * which is defined in pretyping/constrexpr.ml. Your plugin + * will want a different representation. + * + * The important function is Constrintern.interp_constr_evars, + * which converts between a constr_expr and an + * (EConstr.constr, evar_map) pair. This essentially contains + * an internal representation of the term along with some state. + * For more on the state, read /dev/doc/econstr.md. + * + * NOTE ON INTERNING: Always prefer Constrintern.interp_constr_evars + * over Constrintern.interp_constr. The latter is an internal function + * not meant for external use. + * + * To get your initial environment, call Global.env (). + * To get state from that environment, call Evd.from_env on that environment. + * It is important to NEVER use the empty environment or Evd.empty; + * if you do, you will get confusing errors. + * + * NOTE ON STATE: It is important to use the evar_map that is returned to you. + * Otherwise, you may get cryptic errors later in your plugin. + * For example, you may get universe inconsistency errors. + * In general, if a function returns an evar_map to you, that's the one + * you want to thread through the rest of your command. + * + * NOTE ON STYLE: In general, it's better practice to move large + * chunks of OCaml code like this one into an .ml file. We include + * this here because it's really important to understand how to + * thread state in a plugin, and it's easier to see that if it's in the + * top-level file itself. + *) +VERNAC COMMAND EXTEND Intern CLASSIFIED AS QUERY +| [ "Intern" constr(e) ] -> + { + let env = Global.env () in (* use this; never use empty *) + let sigma = Evd.from_env env in (* use this; never use empty *) + let debug sigma = Termops.pr_evar_map ~with_univs:true None env sigma in + Feedback.msg_notice (strbrk "State before intern: " ++ debug sigma); + let (sigma, t) = Constrintern.interp_constr_evars env sigma e in + Feedback.msg_notice (strbrk "State after intern: " ++ debug sigma); + let print t = Printer.pr_econstr_env env sigma t in + Feedback.msg_notice (strbrk "Interned: " ++ print t) + } END -(* The next step is to make something of parsed expression. - Interesting information in interp/constrintern.mli *) - -(* There are several phases of transforming a parsed expression into - the final internal data-type (constr). There exists a collection of - functions that combine all the phases *) - -VERNAC COMMAND EXTEND TakingConstr2 CLASSIFIED AS QUERY -| [ "Cmd2" constr(e) ] -> - { let _ = Constrintern.interp_constr - (Global.env()) - (* Make sure you don't use Evd.empty here, as this does not - check consistency with existing universe constraints. *) - (Evd.from_env (Global.env())) e in - Feedback.msg_notice (strbrk "Cmd2 parsed something legitimate") } +(*** Defining terms ***) + +(* + * To define a term, we start similarly to our intern functionality, + * then we call another function. We define this function in + * the Simple_declare module. + * + * The line #[ poly = Attributes.polymorphic ] says that this command accepts + * polymorphic attributes. + * @SkySkimmer: Here, poly is what the result is bound to in the + * rule's code. Multiple attributes may be used separated by ;, and we have + * punning so foo is equivalent to foo = foo. + * + * The declare_definition function returns the reference + * that was defined. This reference will be present in the new environment. + * If you want to refer to it later in your plugin, you must use an + * updated environment and the constructed reference. + * + * Note since we are now defining a term, we must classify this + * as a side-effect (CLASSIFIED AS SIDEFF). + *) +VERNAC COMMAND EXTEND MyDefine CLASSIFIED AS SIDEFF +| #[ poly = Attributes.polymorphic ] [ "MyDefine" ident(i) ":=" constr(e) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, t) = Constrintern.interp_constr_evars env sigma e in + let r = Simple_declare.declare_definition ~poly i sigma t in + let print r = strbrk "Defined " ++ Printer.pr_global r ++ strbrk "." in + Feedback.msg_notice (print r) + } END -(* This is to show what happens when typing in an empty environment - with an empty evd. - Question for the developers: why does "Cmd3 (fun x : nat => x)." - raise an anomaly, not the same error as "Cmd3 (fun x : a => x)." *) - -VERNAC COMMAND EXTEND TakingConstr3 CLASSIFIED AS QUERY -| [ "Cmd3" constr(e) ] -> - { let _ = Constrintern.interp_constr Environ.empty_env - Evd.empty e in - Feedback.msg_notice - (strbrk "Cmd3 accepted something in the empty context")} +(*** Printing terms ***) + +(* + * This command takes a name and return its value. It does less + * than Print, because it fails on constructors, axioms, and inductive types. + * It signals an error to the user for unsupported terms. + * + * Simple_print contains simple_body_access, which shows how to look up + * a global reference. + *) +VERNAC COMMAND EXTEND ExamplePrint CLASSIFIED AS QUERY +| [ "MyPrint" reference(r) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + try + let t = Simple_print.simple_body_access (Nametab.global r) in + Feedback.msg_notice (Printer.pr_econstr_env env sigma t) + with Failure s -> + CErrors.user_err (str s) + } END -(* When adding a definition, we have to be careful that just - the operation of constructing a well-typed term may already change - the environment, at the level of universe constraints (which - are recorded in the evd component). The function - Constrintern.interp_constr ignores this side-effect, so it should - not be used here. *) - -(* Looking at the interface file interp/constrintern.ml4, I lost - some time because I did not see that the "constr" type appearing - there was "EConstr.constr" and not "Constr.constr". *) - -VERNAC COMMAND EXTEND Define1 CLASSIFIED AS SIDEFF -| #[ poly = polymorphic ] [ "Cmd4" ident(i) constr(e) ] -> - { let v = Constrintern.interp_constr (Global.env()) - (Evd.from_env (Global.env())) e in - Simple_declare.packed_declare_definition ~poly i v } +(* + * This command shows that after you define a new term, + * you can also look it up. But there's a catch! You need to actually + * refresh your environment. Otherwise, the defined term + * will not be in the environment. + * + * Using the global reference as opposed to the ID is generally + * a good idea, otherwise you might end up running into unforeseen + * problems inside of modules and sections and so on. + * + * Inside of simple_body_access, note that it uses Global.env (), + * which refreshes the environment before looking up the term. + *) +VERNAC COMMAND EXTEND DefineLookup CLASSIFIED AS SIDEFF +| #[ poly = Attributes.polymorphic ] [ "DefineLookup" ident(i) ":=" constr(e) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, t) = Constrintern.interp_constr_evars env sigma e in + let r = Simple_declare.declare_definition ~poly i sigma t in + let print r = strbrk "Defined " ++ Printer.pr_global r ++ strbrk "." in + Feedback.msg_notice (print r); + let env = Global.env () in + let sigma = Evd.from_env env in + let t = Simple_print.simple_body_access r in + let print t = strbrk "Found " ++ Printer.pr_econstr_env env sigma t in + Feedback.msg_notice (print t) + } END +(*** Checking terms ***) + +(* + * These are two commands for simple type-checking of terms. + * The bodies and explanations of the differences are in simple_check.ml. + *) + VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY -| [ "Cmd5" constr(e) ] -> - { let v = Constrintern.interp_constr (Global.env()) - (Evd.from_env (Global.env())) e in - let (_, ctx) = v in - let evd = Evd.from_ctx ctx in - Feedback.msg_notice - (Printer.pr_econstr_env (Global.env()) evd - (Simple_check.simple_check1 v)) } +| [ "Check1" constr(e) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, t) = Constrintern.interp_constr_evars env sigma e in + let (sigma, typ) = Simple_check.simple_check1 env sigma t in + Feedback.msg_notice (Printer.pr_econstr_env env sigma typ) + } END VERNAC COMMAND EXTEND Check2 CLASSIFIED AS QUERY -| [ "Cmd6" constr(e) ] -> - { let v = Constrintern.interp_constr (Global.env()) - (Evd.from_env (Global.env())) e in - let evd, ty = Simple_check.simple_check2 v in - Feedback.msg_notice - (Printer.pr_econstr_env (Global.env()) evd ty) } +| [ "Check2" constr(e) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, t) = Constrintern.interp_constr_evars env sigma e in + let typ = Simple_check.simple_check2 env sigma t in + Feedback.msg_notice (Printer.pr_econstr_env env sigma typ) + } END -VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY -| [ "Cmd7" constr(e) ] -> - { let v = Constrintern.interp_constr (Global.env()) - (Evd.from_env (Global.env())) e in - let (a, ctx) = v in - let evd = Evd.from_ctx ctx in - Feedback.msg_notice - (Printer.pr_econstr_env (Global.env()) evd - (Simple_check.simple_check3 v)) } -END +(*** Convertibility ***) -(* This command takes a name and return its value. It does less - than Print, because it fails on constructors, axioms, and inductive types. - This should be improved, because the error message is an anomaly. - Anomalies should never appear even when using a command outside of its - intended use. *) -VERNAC COMMAND EXTEND ExamplePrint CLASSIFIED AS QUERY -| [ "Cmd8" reference(r) ] -> - { let env = Global.env() in - let evd = Evd.from_env env in - Feedback.msg_notice - (Printer.pr_econstr_env env evd - (EConstr.of_constr - (Simple_print.simple_body_access (Nametab.global r)))) } +(* + * This command checks if there is a possible assignment of + * constraints in the state under which the two terms are + * convertible. + *) +VERNAC COMMAND EXTEND Convertible CLASSIFIED AS QUERY +| [ "Convertible" constr(e1) constr(e2) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, t1) = Constrintern.interp_constr_evars env sigma e1 in + let (sigma, t2) = Constrintern.interp_constr_evars env sigma e2 in + match Reductionops.infer_conv env sigma t1 t2 with + | Some _ -> + Feedback.msg_notice (strbrk "Yes :)") + | None -> + Feedback.msg_notice (strbrk "No :(") + } END +(*** Introducing terms ***) + +(* + * We can call the tactics defined in Tactics within our tactics. + * Here we call intros. + *) TACTIC EXTEND my_intro | [ "my_intro" ident(i) ] -> { Tactics.introduction i } END -(* if one write this: - VERNAC COMMAND EXTEND exploreproof CLASSIFIED AS QUERY - it gives an error message that is basically impossible to understand. *) +(*** Exploring proof state ***) +(* + * This command demonstrates exploring the proof state from within + * a command. + * + * Note that Pfedit.get_current_context gets us the environment + * and state within a proof, as opposed to the global environment + * and state. This is important within tactics. + *) VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY -| ![ proof ] [ "Cmd9" ] -> +| ![ proof_query ] [ "ExploreProof" ] -> { fun ~pstate -> - Option.iter (fun (pstate : Proof_global.t) -> - 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 } + 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/doc/plugin_tutorial/tuto1/src/inspector.ml b/doc/plugin_tutorial/tuto1/src/inspector.ml new file mode 100644 index 0000000000..d37cbdb74c --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/inspector.ml @@ -0,0 +1,8 @@ +open Pp + +(* + * Inspect an input and print a feedback message explaining what it is + *) +let print_input (a : 'a) (printer : 'a -> Pp.t) (type_str : string) : unit = + let msg = printer a ++ strbrk (Printf.sprintf " is a %s." type_str) in + Feedback.msg_notice msg diff --git a/doc/plugin_tutorial/tuto1/src/inspector.mli b/doc/plugin_tutorial/tuto1/src/inspector.mli new file mode 100644 index 0000000000..52b970bbe0 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/inspector.mli @@ -0,0 +1,4 @@ +(* + * Inspect an input and print a feedback message explaining what it is + *) +val print_input : 'a -> ('a -> Pp.t) -> string -> unit diff --git a/doc/plugin_tutorial/tuto1/src/simple_check.ml b/doc/plugin_tutorial/tuto1/src/simple_check.ml index 2949adde73..684864a056 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_check.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_check.ml @@ -1,32 +1,14 @@ -let simple_check1 value_with_constraints = - begin - let evalue, st = value_with_constraints in - let evd = Evd.from_ctx st in -(* This is reverse engineered from vernacentries.ml *) -(* The point of renaming is to make sure the bound names printed by Check - can be re-used in `apply with` tactics that use bound names to - refer to arguments. *) - let j = Environ.on_judgment EConstr.of_constr - (Arguments_renaming.rename_typing (Global.env()) - (EConstr.to_constr evd evalue)) in - let {Environ.uj_type=x}=j in x - end - -let simple_check2 value_with_constraints = - let evalue, st = value_with_constraints in - let evd = Evd.from_ctx st in -(* This version should be preferred if bound variable names are not so - important, you want to really verify that the input is well-typed, +let simple_check1 env sigma evalue = +(* This version should be preferred if you want to really + verify that the input is well-typed, and if you want to obtain the type. *) (* Note that the output value is a pair containing a new evar_map: typing will fill out blanks in the term by add evar bindings. *) - Typing.type_of (Global.env()) evd evalue + Typing.type_of env sigma evalue -let simple_check3 value_with_constraints = - let evalue, st = value_with_constraints in - let evd = Evd.from_ctx st in -(* This version should be preferred if bound variable names are not so - important and you already expect the input to have been type-checked - before. Set ~lax to false if you want an anomaly to be raised in - case of a type error. Otherwise a ReTypeError exception is raised. *) - Retyping.get_type_of ~lax:true (Global.env()) evd evalue +let simple_check2 env sigma evalue = +(* This version should be preferred if you already expect the input to + have been type-checked before. Set ~lax to false if you want an anomaly + to be raised in case of a type error. Otherwise a ReTypeError exception + is raised. *) + Retyping.get_type_of ~lax:true env sigma evalue diff --git a/doc/plugin_tutorial/tuto1/src/simple_check.mli b/doc/plugin_tutorial/tuto1/src/simple_check.mli index bcf1bf56cf..4b28ac74fe 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_check.mli +++ b/doc/plugin_tutorial/tuto1/src/simple_check.mli @@ -1,8 +1,5 @@ val simple_check1 : - EConstr.constr Evd.in_evar_universe_context -> EConstr.constr + Environ.env -> Evd.evar_map -> EConstr.constr -> Evd.evar_map * EConstr.constr val simple_check2 : - EConstr.constr Evd.in_evar_universe_context -> Evd.evar_map * EConstr.constr - -val simple_check3 : - EConstr.constr Evd.in_evar_universe_context -> EConstr.constr + Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index e9b91d5a7e..1e582e6456 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -6,11 +6,9 @@ let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = let hook_data = Option.map (fun hook -> hook, uctx, []) hook in DeclareDef.declare_definition ident k ce ubinders imps ?hook_data -let packed_declare_definition ~poly ident value_with_constraints = - let body, ctx = value_with_constraints in - let sigma = Evd.from_ctx ctx in +let declare_definition ~poly ident sigma body = let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in let udecl = UState.default_univ_decl in - ignore (edeclare ident k ~opaque:false sigma udecl body None []) + edeclare ident k ~opaque:false sigma udecl body None [] (* But this definition cannot be undone by Reset ident *) diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.mli b/doc/plugin_tutorial/tuto1/src/simple_declare.mli index fd74e81526..c55b36742f 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.mli +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.mli @@ -1,5 +1,4 @@ open Names -open EConstr -val packed_declare_definition : - poly:bool -> Id.t -> constr Evd.in_evar_universe_context -> unit +val declare_definition : + poly:bool -> Id.t -> Evd.evar_map -> EConstr.t -> Names.GlobRef.t diff --git a/doc/plugin_tutorial/tuto1/src/simple_print.ml b/doc/plugin_tutorial/tuto1/src/simple_print.ml index 22a0163fbb..48b5f2214c 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_print.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_print.ml @@ -12,6 +12,6 @@ let simple_body_access gref = | Globnames.ConstRef cst -> let cb = Environ.lookup_constant cst (Global.env()) in match Global.body_of_constant_body Library.indirect_accessor cb with - | Some(e, _) -> e + | Some(e, _) -> EConstr.of_constr e | None -> failwith "This term has no value" diff --git a/doc/plugin_tutorial/tuto1/src/simple_print.mli b/doc/plugin_tutorial/tuto1/src/simple_print.mli index 254b56ff79..943e26acb6 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_print.mli +++ b/doc/plugin_tutorial/tuto1/src/simple_print.mli @@ -1 +1 @@ -val simple_body_access : Names.GlobRef.t -> Constr.constr +val simple_body_access : Names.GlobRef.t -> EConstr.constr diff --git a/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack b/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack index a797a509e0..9309f78cd0 100644 --- a/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack +++ b/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack @@ -1,3 +1,4 @@ +Inspector Simple_check Simple_declare Simple_print diff --git a/doc/plugin_tutorial/tuto1/theories/Demo.v b/doc/plugin_tutorial/tuto1/theories/Demo.v new file mode 100644 index 0000000000..5723e2f82e --- /dev/null +++ b/doc/plugin_tutorial/tuto1/theories/Demo.v @@ -0,0 +1,95 @@ +From Tuto1 Require Import Loader. + +(*** Printing user inputs ***) + +Definition definition := 5. +What's definition. +What kind of term is definition. +What kind of identifier is definition. + +What is 1 2 3 a list of. +What is a list of. (* no arguments = empty list *) + +Is 1 2 3 nonempty. +(* Is nonempty *) (* does not parse *) + +And is 1 provided. +And is provided. + +(*** Interning terms ***) + +Intern 3. +Intern definition. +Intern (fun (x : Prop) => x). +Intern (fun (x : Type) => x). +Intern (forall (T : Type), T). +Intern (fun (T : Type) (t : T) => t). +Intern _. +Intern (Type : Type). + +(*** Defining terms ***) + +MyDefine n := 1. +Print n. + +MyDefine f := (fun (x : Type) => x). +Print f. + +(*** Printing terms ***) + +MyPrint f. +MyPrint n. +Fail MyPrint nat. + +DefineLookup n' := 1. +DefineLookup f' := (fun (x : Type) => x). + +(*** Checking terms ***) + +Check1 3. +Check1 definition. +Check1 (fun (x : Prop) => x). +Check1 (fun (x : Type) => x). +Check1 (forall (T : Type), T). +Check1 (fun (T : Type) (t : T) => t). +Check1 _. +Check1 (Type : Type). + +Check2 3. +Check2 definition. +Check2 (fun (x : Prop) => x). +Check2 (fun (x : Type) => x). +Check2 (forall (T : Type), T). +Check2 (fun (T : Type) (t : T) => t). +Check2 _. +Check2 (Type : Type). + +(*** Convertibility ***) + +Convertible 1 1. +Convertible (fun (x : Type) => x) (fun (x : Type) => x). +Convertible Type Type. +Convertible 1 ((fun (x : nat) => x) 1). + +Convertible 1 2. +Convertible (fun (x : Type) => x) (fun (x : Prop) => x). +Convertible Type Prop. +Convertible 1 ((fun (x : nat) => x) 2). + +(*** Introducing variables ***) + +Theorem foo: + forall (T : Set) (t : T), T. +Proof. + my_intro T. my_intro t. apply t. +Qed. + +(*** Exploring proof state ***) + +Fail ExploreProof. (* not in a proof *) + +Theorem bar: + forall (T : Set) (t : T), T. +Proof. + ExploreProof. my_intro T. ExploreProof. my_intro t. ExploreProof. apply t. +Qed. diff --git a/doc/plugin_tutorial/tuto3/src/construction_game.ml b/doc/plugin_tutorial/tuto3/src/construction_game.ml index 663113d012..2a2acb6001 100644 --- a/doc/plugin_tutorial/tuto3/src/construction_game.ml +++ b/doc/plugin_tutorial/tuto3/src/construction_game.ml @@ -3,15 +3,15 @@ open Context let find_reference = Coqlib.find_reference [@ocaml.warning "-3"] -let example_sort evd = +let example_sort sigma = (* creating a new sort requires that universes should be recorded in the evd datastructure, so this datastructure also needs to be passed around. *) - let evd, s = Evd.new_sort_variable Evd.univ_rigid evd in + let sigma, s = Evd.new_sort_variable Evd.univ_rigid sigma in let new_type = EConstr.mkSort s in - evd, new_type + sigma, new_type -let c_one evd = +let c_one sigma = (* In the general case, global references may refer to universe polymorphic objects, and their universe has to be made afresh when creating an instance. *) let gr_S = @@ -19,129 +19,129 @@ let c_one evd = (* the long name of "S" was found with the command "About S." *) let gr_O = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "O" in - let evd, c_O = Evarutil.new_global evd gr_O in - let evd, c_S = Evarutil.new_global evd gr_S in + let sigma, c_O = Evarutil.new_global sigma gr_O in + let sigma, c_S = Evarutil.new_global sigma gr_S in (* Here is the construction of a new term by applying functions to argument. *) - evd, EConstr.mkApp (c_S, [| c_O |]) + sigma, EConstr.mkApp (c_S, [| c_O |]) -let dangling_identity env evd = +let dangling_identity env sigma = (* I call this a dangling identity, because it is not polymorph, but the type on which it applies is left unspecified, as it is represented by an existential variable. The declaration for this existential variable needs to be added in the evd datastructure. *) - let evd, type_type = example_sort evd in - let evd, arg_type = Evarutil.new_evar env evd type_type in + let sigma, type_type = example_sort sigma in + let sigma, arg_type = Evarutil.new_evar env sigma type_type in (* Notice the use of a De Bruijn index for the inner occurrence of the bound variable. *) - evd, EConstr.mkLambda(nameR (Names.Id.of_string "x"), arg_type, + sigma, EConstr.mkLambda(nameR (Names.Id.of_string "x"), arg_type, EConstr.mkRel 1) -let dangling_identity2 env evd = +let dangling_identity2 env sigma = (* This example uses directly a function that produces an evar that is meant to be a type. *) - let evd, (arg_type, type_type) = - Evarutil.new_type_evar env evd Evd.univ_rigid in - evd, EConstr.mkLambda(nameR (Names.Id.of_string "x"), arg_type, + let sigma, (arg_type, type_type) = + Evarutil.new_type_evar env sigma Evd.univ_rigid in + sigma, EConstr.mkLambda(nameR (Names.Id.of_string "x"), arg_type, EConstr.mkRel 1) let example_sort_app_lambda () = let env = Global.env () in - let evd = Evd.from_env env in - let evd, c_v = c_one evd in + let sigma = Evd.from_env env in + let sigma, c_v = c_one sigma in (* dangling_identity and dangling_identity2 can be used interchangeably here *) - let evd, c_f = dangling_identity2 env evd in + let sigma, c_f = dangling_identity2 env sigma in let c_1 = EConstr.mkApp (c_f, [| c_v |]) in let _ = Feedback.msg_notice - (Printer.pr_econstr_env env evd c_1) in + (Printer.pr_econstr_env env sigma c_1) in (* type verification happens here. Type verification will update existential variable information in the evd part. *) - let evd, the_type = Typing.type_of env evd c_1 in + let sigma, the_type = Typing.type_of env sigma c_1 in (* At display time, you will notice that the system knows about the existential variable being instantiated to the "nat" type, even though c_1 still contains the meta-variable. *) Feedback.msg_notice - ((Printer.pr_econstr_env env evd c_1) ++ + ((Printer.pr_econstr_env env sigma c_1) ++ str " has type " ++ - (Printer.pr_econstr_env env evd the_type)) + (Printer.pr_econstr_env env sigma the_type)) -let c_S evd = +let c_S sigma = let gr = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "S" in - Evarutil.new_global evd gr + Evarutil.new_global sigma gr -let c_O evd = +let c_O sigma = let gr = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "O" in - Evarutil.new_global evd gr + Evarutil.new_global sigma gr -let c_E evd = +let c_E sigma = let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "EvenNat" in - Evarutil.new_global evd gr + Evarutil.new_global sigma gr -let c_D evd = +let c_D sigma = let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "tuto_div2" in - Evarutil.new_global evd gr + Evarutil.new_global sigma gr -let c_Q evd = +let c_Q sigma = let gr = find_reference "Tuto3" ["Coq"; "Init"; "Logic"] "eq" in - Evarutil.new_global evd gr + Evarutil.new_global sigma gr -let c_R evd = +let c_R sigma = let gr = find_reference "Tuto3" ["Coq"; "Init"; "Logic"] "eq_refl" in - Evarutil.new_global evd gr + Evarutil.new_global sigma gr -let c_N evd = +let c_N sigma = let gr = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "nat" in - Evarutil.new_global evd gr + Evarutil.new_global sigma gr -let c_C evd = +let c_C sigma = let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "C" in - Evarutil.new_global evd gr + Evarutil.new_global sigma gr -let c_F evd = +let c_F sigma = let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "S_ev" in - Evarutil.new_global evd gr + Evarutil.new_global sigma gr -let c_P evd = +let c_P sigma = let gr = find_reference "Tuto3" ["Tuto3"; "Data"] "s_half_proof" in - Evarutil.new_global evd gr + Evarutil.new_global sigma gr (* If c_S was universe polymorphic, we should have created a new constant at each iteration of buildup. *) -let mk_nat evd n = - let evd, c_S = c_S evd in - let evd, c_O = c_O evd in +let mk_nat sigma n = + let sigma, c_S = c_S sigma in + let sigma, c_O = c_O sigma in let rec buildup = function | 0 -> c_O | n -> EConstr.mkApp (c_S, [| buildup (n - 1) |]) in - if n <= 0 then evd, c_O else evd, buildup n + if n <= 0 then sigma, c_O else sigma, buildup n let example_classes n = let env = Global.env () in - let evd = Evd.from_env env in - let evd, c_n = mk_nat evd n in - let evd, n_half = mk_nat evd (n / 2) in - let evd, c_N = c_N evd in - let evd, c_div = c_D evd in - let evd, c_even = c_E evd in - let evd, c_Q = c_Q evd in - let evd, c_R = c_R evd in + let sigma = Evd.from_env env in + let sigma, c_n = mk_nat sigma n in + let sigma, n_half = mk_nat sigma (n / 2) in + let sigma, c_N = c_N sigma in + let sigma, c_div = c_D sigma in + let sigma, c_even = c_E sigma in + let sigma, c_Q = c_Q sigma in + let sigma, c_R = c_R sigma in let arg_type = EConstr.mkApp (c_even, [| c_n |]) in - let evd0 = evd in - let evd, instance = Evarutil.new_evar env evd arg_type in + let sigma0 = sigma in + let sigma, instance = Evarutil.new_evar env sigma arg_type in let c_half = EConstr.mkApp (c_div, [|c_n; instance|]) in - let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd c_half) in - let evd, the_type = Typing.type_of env evd c_half in - let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd c_half) in + let _ = Feedback.msg_notice (Printer.pr_econstr_env env sigma c_half) in + let sigma, the_type = Typing.type_of env sigma c_half in + let _ = Feedback.msg_notice (Printer.pr_econstr_env env sigma c_half) in let proved_equality = EConstr.mkCast(EConstr.mkApp (c_R, [| c_N; c_half |]), Constr.DEFAULTcast, EConstr.mkApp (c_Q, [| c_N; c_half; n_half|])) in (* This is where we force the system to compute with type classes. *) (* Question to coq developers: why do we pass two evd arguments to - solve_remaining_evars? Is the choice of evd0 relevant here? *) - let evd = Pretyping.solve_remaining_evars - (Pretyping.default_inference_flags true) env evd ~initial:evd0 in - let evd, final_type = Typing.type_of env evd proved_equality in - Feedback.msg_notice (Printer.pr_econstr_env env evd proved_equality) + solve_remaining_evars? Is the choice of sigma0 relevant here? *) + let sigma = Pretyping.solve_remaining_evars + (Pretyping.default_inference_flags true) env sigma ~initial:sigma0 in + let sigma, final_type = Typing.type_of env sigma proved_equality in + Feedback.msg_notice (Printer.pr_econstr_env env sigma proved_equality) (* This function, together with definitions in Data.v, shows how to trigger automatic proofs at the time of typechecking, based on @@ -152,36 +152,36 @@ let example_classes n = *) let example_canonical n = let env = Global.env () in - let evd = Evd.from_env env in + let sigma = Evd.from_env env in (* Construct a natural representation of this integer. *) - let evd, c_n = mk_nat evd n in + let sigma, c_n = mk_nat sigma n in (* terms for "nat", "eq", "S_ev", "eq_refl", "C" *) - let evd, c_N = c_N evd in - let evd, c_F = c_F evd in - let evd, c_R = c_R evd in - let evd, c_C = c_C evd in - let evd, c_P = c_P evd in + let sigma, c_N = c_N sigma in + let sigma, c_F = c_F sigma in + let sigma, c_R = c_R sigma in + let sigma, c_C = c_C sigma in + let sigma, c_P = c_P sigma in (* the last argument of C *) let refl_term = EConstr.mkApp (c_R, [|c_N; c_n |]) in (* Now we build two existential variables, for the value of the half and for the "S_ev" structure that triggers the proof search. *) - let evd, ev1 = Evarutil.new_evar env evd c_N in + let sigma, ev1 = Evarutil.new_evar env sigma c_N in (* This is the type for the second existential variable *) let csev = EConstr.mkApp (c_F, [| ev1 |]) in - let evd, ev2 = Evarutil.new_evar env evd csev in + let sigma, ev2 = Evarutil.new_evar env sigma csev in (* Now we build the C structure. *) let test_term = EConstr.mkApp (c_C, [| c_n; ev1; ev2; refl_term |]) in (* Type-checking this term will compute values for the existential variables *) - let evd, final_type = Typing.type_of env evd test_term in + let sigma, final_type = Typing.type_of env sigma test_term in (* The computed type has two parameters, the second one is the proof. *) - let value = match EConstr.kind evd final_type with + let value = match EConstr.kind sigma final_type with | Constr.App(_, [| _; the_half |]) -> the_half | _ -> failwith "expecting the whole type to be \"cmp _ the_half\"" in - let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd value) in + let _ = Feedback.msg_notice (Printer.pr_econstr_env env sigma value) in (* I wish for a nicer way to get the value of ev2 in the evar_map *) - let prf_struct = EConstr.of_constr (EConstr.to_constr evd ev2) in + let prf_struct = EConstr.of_constr (EConstr.to_constr sigma ev2) in let the_prf = EConstr.mkApp (c_P, [| ev1; prf_struct |]) in - let evd, the_statement = Typing.type_of env evd the_prf in + let sigma, the_statement = Typing.type_of env sigma the_prf in Feedback.msg_notice - (Printer.pr_econstr_env env evd the_prf ++ str " has type " ++ - Printer.pr_econstr_env env evd the_statement) + (Printer.pr_econstr_env env sigma the_prf ++ str " has type " ++ + Printer.pr_econstr_env env sigma the_statement) diff --git a/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg b/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg index f4d9e7fd5b..14b8eb5f07 100644 --- a/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg +++ b/doc/plugin_tutorial/tuto3/src/g_tuto3.mlg @@ -14,13 +14,13 @@ open Stdarg VERNAC COMMAND EXTEND ShowTypeConstruction CLASSIFIED AS QUERY | [ "Tuto3_1" ] -> { let env = Global.env () in - let evd = Evd.from_env env in - let evd, s = Evd.new_sort_variable Evd.univ_rigid evd in + let sigma = Evd.from_env env in + let sigma, s = Evd.new_sort_variable Evd.univ_rigid sigma in let new_type_2 = EConstr.mkSort s in - let evd, _ = + let sigma, _ = Typing.type_of (Global.env()) (Evd.from_env (Global.env())) new_type_2 in Feedback.msg_notice - (Printer.pr_econstr_env env evd new_type_2) } + (Printer.pr_econstr_env env sigma new_type_2) } END VERNAC COMMAND EXTEND ShowOneConstruction CLASSIFIED AS QUERY diff --git a/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml b/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml index 2d541087ce..796a65f40d 100644 --- a/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml +++ b/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml @@ -65,10 +65,10 @@ let package i = Goal.enter begin fun gl -> and return the value a. *) (* Remark by Maxime: look for destApp combinator. *) -let unpack_type evd term = +let unpack_type sigma term = let report () = CErrors.user_err (Pp.str "expecting a packed type") in - match EConstr.kind evd term with + match EConstr.kind sigma term with | Constr.App (_, [| ty |]) -> ty | _ -> report () @@ -76,19 +76,19 @@ let unpack_type evd term = A -> pack B -> C and return A, B, C but it is not used in the current version of our tactic. It is kept as an example. *) -let two_lambda_pattern evd term = +let two_lambda_pattern sigma term = let report () = CErrors.user_err (Pp.str "expecting two nested implications") in (* Note that pattern-matching is always done through the EConstr.kind function, which only provides one-level deep patterns. *) - match EConstr.kind evd term with + match EConstr.kind sigma term with (* Here we recognize the outer implication *) | Constr.Prod (_, ty1, l1) -> (* Here we recognize the inner implication *) - (match EConstr.kind evd l1 with + (match EConstr.kind sigma l1 with | Constr.Prod (n2, packed_ty2, deep_conclusion) -> (* Here we recognized that the second type is an application *) - ty1, unpack_type evd packed_ty2, deep_conclusion + ty1, unpack_type sigma packed_ty2, deep_conclusion | _ -> report ()) | _ -> report () @@ -104,22 +104,22 @@ let get_type_of_hyp env id = let repackage i h_hyps_id = Goal.enter begin fun gl -> let env = Goal.env gl in - let evd = Tacmach.New.project gl in + let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_concl gl in let (ty1 : EConstr.t) = get_type_of_hyp env i in let (packed_ty2 : EConstr.t) = get_type_of_hyp env h_hyps_id in - let ty2 = unpack_type evd packed_ty2 in + let ty2 = unpack_type sigma packed_ty2 in let new_packed_type = EConstr.mkApp (c_P (), [| ty1; ty2 |]) in let open EConstr in let new_packed_value = mkApp (c_R (), [| ty1; ty2; mkVar i; mkApp (c_U (), [| ty2; mkVar h_hyps_id|]) |]) in - Refine.refine ~typecheck:true begin fun evd -> - let evd, new_goal = Evarutil.new_evar env evd + Refine.refine ~typecheck:true begin fun sigma -> + let sigma, new_goal = Evarutil.new_evar env sigma (mkArrowR (mkApp(c_H (), [| new_packed_type |])) (Vars.lift 1 concl)) in - evd, mkApp (new_goal, + sigma, mkApp (new_goal, [|mkApp(c_M (), [|new_packed_type; new_packed_value |]) |]) end end 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/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index c1af4d067f..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 @@ -2448,3 +2448,45 @@ types and functions of a :g:`Uint63` module. Said module is not produced by extraction. Instead, it has to be provided by the user (if they want to compile or execute the extracted code). For instance, an implementation of this module can be taken from the kernel of Coq. + +Bidirectionality hints +---------------------- + +When type-checking an application, Coq normally does not use information from +the context to infer the types of the arguments. It only checks after the fact +that the type inferred for the application is coherent with the expected type. +Bidirectionality hints make it possible to specify that after type-checking the +first arguments of an application, typing information should be propagated from +the context to help inferring the types of the remaining arguments. + +.. cmd:: Arguments @qualid {* @ident__1 } & {* @ident__2} + :name: Arguments (bidirectionality hints) + + This commands tells the typechecking algorithm, when type-checking + applications of :n:`@qualid`, to first type-check the arguments in + :n:`@ident__1` and then propagate information from the typing context to + type-check the remaining arguments (in :n:`@ident__2`). + +.. example:: + + In a context where a coercion was declared from ``bool`` to ``nat``: + + .. coqtop:: in reset + + Definition b2n (b : bool) := if b then 1 else 0. + Coercion b2n : bool >-> nat. + + Coq cannot automatically coerce existential statements over ``bool`` to + statements over ``nat``, because the need for inserting a coercion is known + only from the expected type of a subterm: + + .. coqtop:: all + + Fail Check (ex_intro _ true _ : exists n : nat, n > 0). + + However, a suitable bidirectionality hint makes the example work: + + .. coqtop:: all + + Arguments ex_intro _ _ & _ _. + Check (ex_intro _ true _ : exists n : nat, n > 0). diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 5f2e911ff9..36eeff6192 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -655,6 +655,8 @@ this features has the same semantics as in Ltac1. In particular, a ``reverse`` flag can be specified to match hypotheses from the more recently introduced to the least recently introduced one. +.. _ltac2_notations: + Notations --------- @@ -679,6 +681,11 @@ The following scopes are built-in. + parses :n:`c = @term` and produces :n:`constr:(c)` + This scope can be parameterized by a list of delimiting keys of interpretation + scopes (as described in :ref:`LocalInterpretationRulesForNotations`), + describing how to interpret the parsed term. For instance, :n:`constr(A, B)` + parses :n:`c = @term` and produces :n:`constr:(c%A%B)`. + - :n:`ident`: + parses :n:`id = @ident` and produces :n:`ident:(id)` diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 3f966755ca..0cff987a27 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -535,19 +535,6 @@ Requesting information eexists ?[n]. Show n. - .. cmdv:: Show Script - :name: Show Script - - Displays the whole list of tactics applied from the - beginning of the current proof. This tactics script may contain some - holes (subgoals not yet proved). They are printed under the form - - ``<Your Tactic Text here>``. - - .. deprecated:: 8.10 - - Please use a text editor. - .. cmdv:: Show Proof :name: Show Proof @@ -705,9 +692,10 @@ command in CoqIDE. You can change the background colors shown for diffs from th lets you control other attributes of the highlights, such as the foreground color, bold, italic, underline and strikeout. -Note: As of this writing (August 2018), Proof General will need minor changes -to be able to show diffs correctly. We hope it will support this feature soon. -See https://github.com/ProofGeneral/PG/issues/381 for the current status. +As of June 2019, Proof General can also display Coq-generated proof diffs automatically. +Please see the PG documentation section +"`Showing Proof Diffs" <https://proofgeneral.github.io/doc/master/userman/Coq-Proof-General#Showing-Proof-Diffs>`_) +for details. How diffs are calculated ```````````````````````` diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index b0bafb7930..7f68f24c22 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -126,7 +126,6 @@ let commands = [ "Show Intros"; "Show Programs"; "Show Proof"; - "Show Script"; "Show Tree";*) "Structure"; "Syntactic Definition"; @@ -221,7 +220,6 @@ let state_preserving = [ "Show Intro"; "Show Intros"; "Show Proof"; - "Show Script"; "Show Tree"; "Test Printing If"; 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/interp/constrextern.ml b/interp/constrextern.ml index fe50bd4b08..701c07dc8d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -757,11 +757,10 @@ let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_lo (* mapping glob_constr to constr_expr *) let extern_glob_sort = function - | GSProp -> GSProp - | GProp -> GProp - | GSet -> GSet - | GType _ as s when !print_universes -> s - | GType _ -> GType [] + (* In case we print a glob_constr w/o having passed through detyping *) + | UNamed [(GSProp,0) | (GProp,0) | (GSet,0)] as u -> u + | UNamed _ when not !print_universes -> UAnonymous {rigid=true} + | UNamed _ | UAnonymous _ as u -> u let extern_universes = function | Some _ as l when !print_universes -> l @@ -1312,10 +1311,10 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) - | PSort Sorts.InSProp -> GSort GSProp - | PSort Sorts.InProp -> GSort GProp - | PSort Sorts.InSet -> GSort GSet - | PSort Sorts.InType -> GSort (GType []) + | PSort Sorts.InSProp -> GSort (UNamed [GSProp,0]) + | PSort Sorts.InProp -> GSort (UNamed [GProp,0]) + | PSort Sorts.InSet -> GSort (UNamed [GSet,0]) + | PSort Sorts.InType -> GSort (UAnonymous {rigid=true}) | PInt i -> GInt i let extern_constr_pattern env sigma pat = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 1dd68f2abf..1a81dc41a1 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -998,18 +998,10 @@ let intern_reference qid = in Smartlocate.global_of_extended_global r -let sort_info_of_level_info (info: level_info) : (Libnames.qualid * int) option = - match info with - | UAnonymous -> None - | UUnknown -> None - | UNamed id -> Some (id, 0) - let glob_sort_of_level (level: glob_level) : glob_sort = match level with - | GSProp -> GSProp - | GProp -> GProp - | GSet -> GSet - | GType info -> GType [sort_info_of_level_info info] + | UAnonymous {rigid} -> UAnonymous {rigid} + | UNamed id -> UNamed [id,0] (* Is it a global reference or a syntactic definition? *) let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = @@ -1045,7 +1037,7 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = DAst.make ?loc @@ GApp (DAst.make ?loc:loc' @@ GRef (ref, us), arg) | _ -> err () end - | Some [s], GSort (GType []) -> DAst.make ?loc @@ GSort (glob_sort_of_level s) + | Some [s], GSort (UAnonymous {rigid=true}) -> DAst.make ?loc @@ GSort (glob_sort_of_level s) | Some [_old_level], GSort _new_sort -> (* TODO: add old_level and new_sort to the error message *) user_err ?loc (str "Cannot change universe level of notation " ++ pr_qualid qid) diff --git a/interp/declare.ml b/interp/declare.ml index b3595b2dae..cc6f29f756 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -53,6 +53,13 @@ let load_constant i ((sp,kn), obj) = Nametab.push (Nametab.Until i) sp (ConstRef con); add_constant_kind con obj.cst_kind +let cooking_info segment = + let modlist = replacement_context () in + let { abstr_ctx = hyps; abstr_subst = subst; abstr_uctx = uctx } = segment in + let named_ctx = List.map fst hyps in + let abstract = (named_ctx, subst, uctx) in + { Opaqueproof.modlist; abstract } + (* Opening means making the name without its module qualification available *) let open_constant i ((sp,kn), obj) = (* Never open a local definition *) @@ -89,13 +96,10 @@ let cache_constant ((sp,kn), obj) = let discharge_constant ((sp, kn), obj) = let con = Constant.make1 kn in let from = Global.lookup_constant con in - let modlist = replacement_context () in - let { abstr_ctx = hyps; abstr_subst = subst; abstr_uctx = uctx } = section_segment_of_constant con in - let abstract = (named_of_variable_context hyps, subst, uctx) in - let new_decl = { from; info = { Opaqueproof.modlist; abstract } } in + let info = cooking_info (section_segment_of_constant con) in (* This is a hack: when leaving a section, we lose the constant definition, so we have to store it in the libobject to be able to retrieve it after. *) - Some { obj with cst_decl = Some new_decl; } + Some { obj with cst_decl = Some { from; info } } (* Hack to reduce the size of .vo: we keep only what load/open needs *) let dummy_constant cst = { @@ -312,9 +316,8 @@ let cache_inductive ((sp,kn),mie) = let discharge_inductive ((sp,kn),mie) = let mind = Global.mind_of_delta_kn kn in let mie = Global.lookup_mind mind in - let repl = replacement_context () in - let info = section_segment_of_mutual_inductive mind in - Some (Discharge.process_inductive info repl mie) + let info = cooking_info (section_segment_of_mutual_inductive mind) in + Some (Cooking.cook_inductive info mie) let dummy_one_inductive_entry mie = { mind_entry_typename = mie.mind_entry_typename; diff --git a/interp/declare.mli b/interp/declare.mli index 795d9a767d..0b1a396a34 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -90,5 +90,4 @@ val declare_univ_binders : GlobRef.t -> UnivNames.universe_binders -> unit val declare_universe_context : polymorphic -> Univ.ContextSet.t -> unit val do_universe : polymorphic -> lident list -> unit -val do_constraint : polymorphic -> (Glob_term.glob_level * Univ.constraint_type * Glob_term.glob_level) list -> - unit +val do_constraint : polymorphic -> Glob_term.glob_constraint list -> unit diff --git a/interp/discharge.ml b/interp/discharge.ml deleted file mode 100644 index 1efd13adb1..0000000000 --- a/interp/discharge.ml +++ /dev/null @@ -1,118 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Util -open Term -open Constr -open Vars -open Declarations -open Cooking -open Entries - -(********************************) -(* Discharging mutual inductive *) - -(* Replace - - Var(y1)..Var(yq):C1..Cq |- Ij:Bj - Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti - - by - - |- Ij: (y1..yq:C1..Cq)Bj - I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] -*) - -let abstract_inductive decls nparamdecls inds = - let ntyp = List.length inds in - let ndecls = Context.Named.length decls in - let args = Context.Named.to_instance mkVar (List.rev decls) in - let args = Array.of_list args in - let subs = List.init ntyp (fun k -> lift ndecls (mkApp(mkRel (k+1),args))) in - let inds' = - List.map - (function (tname,arity,template,cnames,lc) -> - let lc' = List.map (substl subs) lc in - let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b decls) lc' in - let arity' = Termops.it_mkNamedProd_wo_LetIn arity decls in - (tname,arity',template,cnames,lc'')) - inds in - let nparamdecls' = nparamdecls + Array.length args in -(* To be sure to be the same as before, should probably be moved to process_inductive *) - let params' = let (_,arity,_,_,_) = List.hd inds' in - let (params,_) = decompose_prod_n_assum nparamdecls' arity in - params - in - let ind'' = - List.map - (fun (a,arity,template,c,lc) -> - let _, short_arity = decompose_prod_n_assum nparamdecls' arity in - let shortlc = - List.map (fun c -> snd (decompose_prod_n_assum nparamdecls' c)) lc in - { mind_entry_typename = a; - mind_entry_arity = short_arity; - mind_entry_template = template; - mind_entry_consnames = c; - mind_entry_lc = shortlc }) - inds' - in (params',ind'') - -let refresh_polymorphic_type_of_inductive (_,mip) = - match mip.mind_arity with - | RegularArity s -> s.mind_user_arity, false - | TemplateArity ar -> - let ctx = List.rev mip.mind_arity_ctxt in - mkArity (List.rev ctx, Sorts.sort_of_univ ar.template_level), true - -let process_inductive info modlist mib = - let section_decls = Lib.named_of_variable_context info.Lib.abstr_ctx in - let nparamdecls = Context.Rel.length mib.mind_params_ctxt in - let subst, ind_univs = - match mib.mind_universes with - | Monomorphic ctx -> Univ.empty_level_subst, Monomorphic_entry ctx - | Polymorphic auctx -> - let subst, auctx = Lib.discharge_abstract_universe_context info auctx in - let nas = Univ.AUContext.names auctx in - let auctx = Univ.AUContext.repr auctx in - subst, Polymorphic_entry (nas, auctx) - in - let variance = match mib.mind_variance with - | None -> None - | Some _ -> Some (InferCumulativity.dummy_variance ind_univs) - in - let discharge c = Vars.subst_univs_level_constr subst (expmod_constr modlist c) in - let inds = - Array.map_to_list - (fun mip -> - let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in - let arity = discharge ty in - let lc = Array.map discharge mip.mind_user_lc in - (mip.mind_typename, - arity, template, - Array.to_list mip.mind_consnames, - Array.to_list lc)) - mib.mind_packets in - let section_decls' = Context.Named.map discharge section_decls in - let (params',inds') = abstract_inductive section_decls' nparamdecls inds in - let record = match mib.mind_record with - | PrimRecord info -> - Some (Some (Array.map (fun (x,_,_,_) -> x) info)) - | FakeRecord -> Some None - | NotRecord -> None - in - { mind_entry_record = record; - mind_entry_finite = mib.mind_finite; - mind_entry_params = params'; - mind_entry_inds = inds'; - mind_entry_private = mib.mind_private; - mind_entry_variance = variance; - mind_entry_universes = ind_univs - } - diff --git a/interp/discharge.mli b/interp/discharge.mli deleted file mode 100644 index f7408937cf..0000000000 --- a/interp/discharge.mli +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Declarations -open Entries -open Opaqueproof - -val process_inductive : - Lib.abstr_info -> work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/interp/interp.mllib b/interp/interp.mllib index 1262dbb181..b65a171ef9 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -16,5 +16,4 @@ Implicit_quantifiers Constrintern Modintern Constrextern -Discharge Declare diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 7f084fffdd..08619d912e 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -1190,7 +1190,11 @@ let rec match_ inner u alp metas sigma a1 a2 = Array.fold_left2 (match_in u alp metas) sigma bl1 bl2 | GCast(t1, c1), NCast(t2, c2) -> match_cast (match_in u alp metas) (match_in u alp metas sigma t1 t2) c1 c2 - | GSort (GType _), NSort (GType _) when not u -> sigma + + (* Next pair of lines useful only if not coming from detyping *) + | GSort (UNamed [(GProp|GSet),0]), NSort (UAnonymous _) -> raise No_match + | GSort _, NSort (UAnonymous _) when not u -> sigma + | GSort s1, NSort s2 when glob_sort_eq s1 s2 -> sigma | GInt i1, NInt i2 when Uint63.equal i1 i2 -> sigma | GPatVar _, NHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 13851319cd..1336e3e8bf 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -165,25 +165,33 @@ type 'opaque result = { cook_context : Constr.named_context option; } -let on_body ml hy f = function - | Undef _ as x -> x - | Def cs -> Def (Mod_subst.from_val (f (Mod_subst.force_constr cs))) - | OpaqueDef o -> - OpaqueDef (Opaqueproof.discharge_direct_opaque ~cook_constr:f - { Opaqueproof.modlist = ml; abstract = hy } o) - | Primitive _ -> CErrors.anomaly (Pp.str "Primitives cannot be cooked") - let expmod_constr_subst cache modlist subst c = let subst = Univ.make_instance_subst subst in let c = expmod_constr cache modlist c in Vars.subst_univs_level_constr subst c -let cook_constr { Opaqueproof.modlist ; abstract = (vars, subst, _) } c = - let cache = RefTable.create 13 in - let expmod = expmod_constr_subst cache modlist subst in - let hyps = Context.Named.map expmod vars in - let hyps = abstract_context hyps in - abstract_constant_body (expmod c) hyps +let discharge_abstract_universe_context subst abs_ctx auctx = + (** Given a named instance [subst := u₀ ... uₙ₋₁] together with an abstract + context [auctx0 := 0 ... n - 1 |= C{0, ..., n - 1}] of the same length, + and another abstract context relative to the former context + [auctx := 0 ... m - 1 |= C'{u₀, ..., uₙ₋₁, 0, ..., m - 1}], + construct the lifted abstract universe context + [0 ... n - 1 n ... n + m - 1 |= + C{0, ... n - 1} ∪ + C'{0, ..., n - 1, n, ..., n + m - 1} ] + together with the instance + [u₀ ... uₙ₋₁ Var(0) ... Var (m - 1)]. + *) + if (Univ.Instance.is_empty subst) then + (** Still need to take the union for the constraints between globals *) + subst, (AUContext.union abs_ctx auctx) + else + let open Univ in + let ainst = make_abstract_instance auctx in + let subst = Instance.append subst ainst in + let substf = make_instance_subst subst in + let auctx = Univ.subst_univs_level_abstract_universe_context substf auctx in + subst, (AUContext.union abs_ctx auctx) let lift_univs cb subst auctx0 = match cb.const_universes with @@ -191,26 +199,24 @@ let lift_univs cb subst auctx0 = assert (AUContext.is_empty auctx0); subst, (Monomorphic ctx) | Polymorphic auctx -> - (** Given a named instance [subst := u₀ ... uₙ₋₁] together with an abstract - context [auctx0 := 0 ... n - 1 |= C{0, ..., n - 1}] of the same length, - and another abstract context relative to the former context - [auctx := 0 ... m - 1 |= C'{u₀, ..., uₙ₋₁, 0, ..., m - 1}], - construct the lifted abstract universe context - [0 ... n - 1 n ... n + m - 1 |= - C{0, ... n - 1} ∪ - C'{0, ..., n - 1, n, ..., n + m - 1} ] - together with the instance - [u₀ ... uₙ₋₁ Var(0) ... Var (m - 1)]. - *) - if (Univ.Instance.is_empty subst) then - (** Still need to take the union for the constraints between globals *) - subst, (Polymorphic (AUContext.union auctx0 auctx)) - else - let ainst = Univ.make_abstract_instance auctx in - let subst = Instance.append subst ainst in - let substf = Univ.make_instance_subst subst in - let auctx' = Univ.subst_univs_level_abstract_universe_context substf auctx in - subst, (Polymorphic (AUContext.union auctx0 auctx')) + let subst, auctx = discharge_abstract_universe_context subst auctx0 auctx in + subst, (Polymorphic auctx) + +let cook_constr { Opaqueproof.modlist ; abstract } (univs, c) = + let cache = RefTable.create 13 in + let abstract, usubst, abs_ctx = abstract in + let ainst = Instance.of_array (Array.init univs Level.var) in + let usubst = Instance.append usubst ainst in + let expmod = expmod_constr_subst cache modlist usubst in + let hyps = Context.Named.map expmod abstract in + let hyps = abstract_context hyps in + let c = abstract_constant_body (expmod c) hyps in + univs + AUContext.size abs_ctx, c + +let cook_constr infos univs c = + let fold info (univs, c) = cook_constr info (univs, c) in + let (_, c) = List.fold_right fold infos (univs, c) in + c let cook_constant { from = cb; info } = let { Opaqueproof.modlist; abstract } = info in @@ -221,9 +227,12 @@ let cook_constant { from = cb; info } = let hyps0 = Context.Named.map expmod abstract in let hyps = abstract_context hyps0 in let map c = abstract_constant_body (expmod c) hyps in - let body = on_body modlist (hyps0, usubst, abs_ctx) - map - cb.const_body + let body = match cb.const_body with + | Undef _ as x -> x + | Def cs -> Def (Mod_subst.from_val (map (Mod_subst.force_constr cs))) + | OpaqueDef o -> + OpaqueDef (Opaqueproof.discharge_direct_opaque info o) + | Primitive _ -> CErrors.anomaly (Pp.str "Primitives cannot be cooked") in let const_hyps = Context.Named.fold_outside (fun decl hyps -> @@ -248,4 +257,115 @@ let cook_constant { from = cb; info } = (* let cook_constant_key = CProfile.declare_profile "cook_constant" *) (* let cook_constant = CProfile.profile2 cook_constant_key cook_constant *) +(********************************) +(* Discharging mutual inductive *) + +(* Replace + + Var(y1)..Var(yq):C1..Cq |- Ij:Bj + Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti + + by + + |- Ij: (y1..yq:C1..Cq)Bj + I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] +*) + +let it_mkNamedProd_wo_LetIn b d = + List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c) b d + +let abstract_inductive decls nparamdecls inds = + let open Entries in + let ntyp = List.length inds in + let ndecls = Context.Named.length decls in + let args = Context.Named.to_instance mkVar (List.rev decls) in + let args = Array.of_list args in + let subs = List.init ntyp (fun k -> lift ndecls (mkApp(mkRel (k+1),args))) in + let inds' = + List.map + (function (tname,arity,template,cnames,lc) -> + let lc' = List.map (Vars.substl subs) lc in + let lc'' = List.map (fun b -> it_mkNamedProd_wo_LetIn b decls) lc' in + let arity' = it_mkNamedProd_wo_LetIn arity decls in + (tname,arity',template,cnames,lc'')) + inds in + let nparamdecls' = nparamdecls + Array.length args in +(* To be sure to be the same as before, should probably be moved to cook_inductive *) + let params' = let (_,arity,_,_,_) = List.hd inds' in + let (params,_) = decompose_prod_n_assum nparamdecls' arity in + params + in + let ind'' = + List.map + (fun (a,arity,template,c,lc) -> + let _, short_arity = decompose_prod_n_assum nparamdecls' arity in + let shortlc = + List.map (fun c -> snd (decompose_prod_n_assum nparamdecls' c)) lc in + { mind_entry_typename = a; + mind_entry_arity = short_arity; + mind_entry_template = template; + mind_entry_consnames = c; + mind_entry_lc = shortlc }) + inds' + in (params',ind'') + +let refresh_polymorphic_type_of_inductive (_,mip) = + match mip.mind_arity with + | RegularArity s -> s.mind_user_arity, false + | TemplateArity ar -> + let ctx = List.rev mip.mind_arity_ctxt in + mkArity (List.rev ctx, Sorts.sort_of_univ ar.template_level), true + +let dummy_variance = let open Entries in function + | Monomorphic_entry _ -> assert false + | Polymorphic_entry (_,uctx) -> Array.make (Univ.UContext.size uctx) Univ.Variance.Irrelevant + +let cook_inductive { Opaqueproof.modlist; abstract } mib = + let open Entries in + let (section_decls, subst, abs_uctx) = abstract in + let nparamdecls = Context.Rel.length mib.mind_params_ctxt in + let subst, ind_univs = + match mib.mind_universes with + | Monomorphic ctx -> Univ.empty_level_subst, Monomorphic_entry ctx + | Polymorphic auctx -> + let subst, auctx = discharge_abstract_universe_context subst abs_uctx auctx in + let subst = Univ.make_instance_subst subst in + let nas = Univ.AUContext.names auctx in + let auctx = Univ.AUContext.repr auctx in + subst, Polymorphic_entry (nas, auctx) + in + let variance = match mib.mind_variance with + | None -> None + | Some _ -> Some (dummy_variance ind_univs) + in + let cache = RefTable.create 13 in + let discharge c = Vars.subst_univs_level_constr subst (expmod_constr cache modlist c) in + let inds = + Array.map_to_list + (fun mip -> + let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in + let arity = discharge ty in + let lc = Array.map discharge mip.mind_user_lc in + (mip.mind_typename, + arity, template, + Array.to_list mip.mind_consnames, + Array.to_list lc)) + mib.mind_packets in + let section_decls' = Context.Named.map discharge section_decls in + let (params',inds') = abstract_inductive section_decls' nparamdecls inds in + let record = match mib.mind_record with + | PrimRecord info -> + Some (Some (Array.map (fun (x,_,_,_) -> x) info)) + | FakeRecord -> Some None + | NotRecord -> None + in + { mind_entry_record = record; + mind_entry_finite = mib.mind_finite; + mind_entry_params = params'; + mind_entry_inds = inds'; + mind_entry_private = mib.mind_private; + mind_entry_variance = variance; + mind_entry_universes = ind_univs + } + let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 024eed1285..934b7c6b50 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -28,7 +28,10 @@ type 'opaque result = { } val cook_constant : recipe -> Opaqueproof.opaque result -val cook_constr : Opaqueproof.cooking_info -> constr -> constr +val cook_constr : Opaqueproof.cooking_info list -> int -> constr -> constr + +val cook_inductive : + Opaqueproof.cooking_info -> mutual_inductive_body -> Entries.mutual_inductive_entry (** {6 Utility functions used in module [Discharge]. } *) diff --git a/kernel/dune b/kernel/dune index 5b23a705ae..4038bf5638 100644 --- a/kernel/dune +++ b/kernel/dune @@ -3,7 +3,7 @@ (synopsis "The Coq Kernel") (public_name coq.kernel) (wrapped false) - (modules (:standard \ genOpcodeFiles uint63_x86 uint63_amd64 write_uint63)) + (modules (:standard \ genOpcodeFiles uint63_i386_31 uint63_amd64_63 write_uint63)) (libraries lib byterun dynlink)) (executable @@ -14,15 +14,10 @@ (targets copcodes.ml) (action (with-stdout-to %{targets} (run ./genOpcodeFiles.exe copml)))) -(executable - (name write_uint63) - (modules write_uint63) - (libraries unix)) - (rule (targets uint63.ml) - (deps (:gen ./write_uint63.exe) uint63_x86.ml uint63_amd64.ml) - (action (run %{gen}))) + (deps (:gen-file uint63_%{ocaml-config:architecture}_%{ocaml-config:int_size}.ml)) + (action (copy# %{gen-file} %{targets}))) (documentation (package coq)) diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 1971c67c61..e18b726111 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -16,19 +16,22 @@ open Mod_subst type work_list = (Instance.t * Id.t array) Cmap.t * (Instance.t * Id.t array) Mindmap.t +type cooking_info = { + modlist : work_list; + abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } + type indirect_accessor = { access_proof : DirPath.t -> int -> constr option; + access_discharge : cooking_info list -> int -> constr -> constr; } -type cooking_info = { - modlist : work_list; - abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } type proofterm = (constr * Univ.ContextSet.t) Future.computation +type universes = int type opaque = | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) - | Direct of cooking_info list * proofterm + | Direct of universes * cooking_info list * proofterm type opaquetab = { - opaque_val : (cooking_info list * proofterm) Int.Map.t; + opaque_val : (int * cooking_info list * proofterm) Int.Map.t; (** Actual proof terms *) opaque_len : int; (** Size of the above map *) @@ -43,14 +46,14 @@ let empty_opaquetab = { let not_here () = CErrors.user_err Pp.(str "Cannot access opaque delayed proof") -let create cu = Direct ([],cu) +let create ~univs cu = Direct (univs, [],cu) let turn_indirect dp o tab = match o with | Indirect (_,_,i) -> if not (Int.Map.mem i tab.opaque_val) then CErrors.anomaly (Pp.str "Indirect in a different table.") else CErrors.anomaly (Pp.str "Already an indirect opaque.") - | Direct (d,cu) -> + | Direct (nunivs, d, cu) -> (* Invariant: direct opaques only exist inside sections, we turn them indirect as soon as we are at toplevel. At this moment, we perform hashconsing of their contents, potentially as a future. *) @@ -61,7 +64,7 @@ let turn_indirect dp o tab = match o with in let cu = Future.chain cu hcons in let id = tab.opaque_len in - let opaque_val = Int.Map.add id (d,cu) tab.opaque_val in + let opaque_val = Int.Map.add id (nunivs, d,cu) tab.opaque_val in let opaque_dir = if DirPath.equal dp tab.opaque_dir then tab.opaque_dir else if DirPath.equal tab.opaque_dir DirPath.initial then dp @@ -74,10 +77,10 @@ let subst_opaque sub = function | Indirect (s,dp,i) -> Indirect (sub::s,dp,i) | Direct _ -> CErrors.anomaly (Pp.str "Substituting a Direct opaque.") -let discharge_direct_opaque ~cook_constr ci = function +let discharge_direct_opaque ci = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") - | Direct (d,cu) -> - Direct (ci::d,Future.chain cu (fun (c, u) -> cook_constr c, u)) + | Direct (n, d, cu) -> + Direct (n, ci :: d, cu) let join except cu = match except with | None -> ignore (Future.join cu) @@ -86,54 +89,61 @@ let join except cu = match except with else ignore (Future.join cu) let join_opaque ?except { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> join except cu + | Direct (_,_,cu) -> join except cu | Indirect (_,dp,i) -> if DirPath.equal dp odp then - let fp = snd (Int.Map.find i prfs) in + let (_, _, fp) = Int.Map.find i prfs in join except fp let force_proof access { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> - fst(Future.force cu) + | Direct (n, d, cu) -> + let (c, _) = Future.force cu in + access.access_discharge d n c | Indirect (l,dp,i) -> - let pt = + let c = if DirPath.equal dp odp - then Future.chain (snd (Int.Map.find i prfs)) fst + then + let (n, d, cu) = Int.Map.find i prfs in + let (c, _) = Future.force cu in + access.access_discharge d n c else match access.access_proof dp i with | None -> not_here () - | Some v -> Future.from_val v + | Some v -> v in - let c = Future.force pt in force_constr (List.fold_right subst_substituted l (from_val c)) let force_constraints _access { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> snd(Future.force cu) + | Direct (_,_,cu) -> + snd(Future.force cu) | Indirect (_,dp,i) -> if DirPath.equal dp odp - then snd (Future.force (snd (Int.Map.find i prfs))) + then + let (_, _, cu) = Int.Map.find i prfs in + snd (Future.force cu) else Univ.ContextSet.empty let get_direct_constraints = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") -| Direct (_, cu) -> Future.chain cu snd +| Direct (_, _, cu) -> Future.chain cu snd module FMap = Future.UUIDMap let dump ?(except = Future.UUIDSet.empty) { opaque_val = otab; opaque_len = n; _ } = - let opaque_table = Array.make n None in - let disch_table = Array.make n [] in + let opaque_table = Array.make n ([], 0, None) in let f2t_map = ref FMap.empty in - let iter n (d, cu) = + let iter n (univs, d, cu) = let uid = Future.uuid cu in let () = f2t_map := FMap.add (Future.uuid cu) n !f2t_map in - if Future.is_val cu then - let (c, _) = Future.force cu in - opaque_table.(n) <- Some c - else if Future.UUIDSet.mem uid except then - disch_table.(n) <- d - else - CErrors.anomaly - Pp.(str"Proof object "++int n++str" is not checked nor to be checked") + let c = + if Future.is_val cu then + let (c, _) = Future.force cu in + Some c + else if Future.UUIDSet.mem uid except then None + else + CErrors.anomaly + Pp.(str"Proof object "++int n++str" is not checked nor to be checked") + in + opaque_table.(n) <- (d, univs, c) in let () = Int.Map.iter iter otab in - opaque_table, disch_table, !f2t_map + opaque_table, !f2t_map diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 46b0500507..6e275649cd 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -28,15 +28,23 @@ type opaque val empty_opaquetab : opaquetab (** From a [proofterm] to some [opaque]. *) -val create : proofterm -> opaque +val create : univs:int -> proofterm -> opaque (** Turn a direct [opaque] into an indirect one. It is your responsibility to hashcons the inner term beforehand. The integer is an hint of the maximum id used so far *) val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab +type work_list = (Univ.Instance.t * Id.t array) Cmap.t * + (Univ.Instance.t * Id.t array) Mindmap.t + +type cooking_info = { + modlist : work_list; + abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } + type indirect_accessor = { access_proof : DirPath.t -> int -> constr option; + access_discharge : cooking_info list -> int -> constr -> constr; } (** When stored indirectly, opaque terms are indexed by their library dirpath and an integer index. The two functions above activate @@ -51,23 +59,11 @@ val get_direct_constraints : opaque -> Univ.ContextSet.t Future.computation val subst_opaque : substitution -> opaque -> opaque -type work_list = (Univ.Instance.t * Id.t array) Cmap.t * - (Univ.Instance.t * Id.t array) Mindmap.t - -type cooking_info = { - modlist : work_list; - abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } - -(* The type has two caveats: - 1) cook_constr is defined after - 2) we have to store the input in the [opaque] in order to be able to - discharge it when turning a .vi into a .vo *) val discharge_direct_opaque : - cook_constr:(constr -> constr) -> cooking_info -> opaque -> opaque + cooking_info -> opaque -> opaque val join_opaque : ?except:Future.UUIDSet.t -> opaquetab -> opaque -> unit val dump : ?except:Future.UUIDSet.t -> opaquetab -> - Constr.t option array * - cooking_info list array * + (cooking_info list * int * Constr.t option) array * int Future.UUIDMap.t diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 9f7466902d..824400b4e3 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -231,7 +231,7 @@ let check_engagement env expected_impredicative_set = type side_effect = { from_env : Declarations.structure_body CEphemeron.key; seff_constant : Constant.t; - seff_body : (Constr.t * Univ.ContextSet.t) Declarations.constant_body; + seff_body : Constr.t Declarations.constant_body; seff_role : Entries.side_effect_role; } @@ -299,11 +299,6 @@ let concat_private = SideEffects.concat let universes_of_private eff = let fold acc eff = - let acc = match eff.seff_body.const_body with - | Def _ -> acc - | OpaqueDef (_, ctx) -> ctx :: acc - | Primitive _ | Undef _ -> assert false - in match eff.seff_body.const_universes with | Monomorphic ctx -> ctx :: acc | Polymorphic _ -> acc @@ -601,7 +596,7 @@ let inline_side_effects env body side_eff = let fold (subst, var, ctx, args) (c, cb) = let (b, opaque) = match cb.const_body with | Def b -> (Mod_subst.force_constr b, false) - | OpaqueDef (b, _) -> (b, true) + | OpaqueDef b -> (b, true) | _ -> assert false in match cb.const_universes with @@ -689,13 +684,13 @@ let constant_entry_of_side_effect eff = | Polymorphic auctx -> Polymorphic_entry (Univ.AUContext.names auctx, Univ.AUContext.repr auctx) in - let pt = + let p = match cb.const_body with - | OpaqueDef (b, c) -> b, c - | Def b -> Mod_subst.force_constr b, Univ.ContextSet.empty + | OpaqueDef b -> b + | Def b -> Mod_subst.force_constr b | _ -> assert false in DefinitionEntry { - const_entry_body = Future.from_val (pt, ()); + const_entry_body = Future.from_val ((p, Univ.ContextSet.empty), ()); const_entry_secctx = None; const_entry_feedback = None; const_entry_type = Some cb.const_type; @@ -721,11 +716,6 @@ let export_side_effects mb env (b_ctx, eff) = match cb.const_universes with | Polymorphic _ -> env | Monomorphic ctx -> - let ctx = match eff.seff_body.const_body with - | Def _ -> ctx - | OpaqueDef (_, ctx') -> Univ.ContextSet.union ctx' ctx - | Undef _ | Primitive _ -> assert false - in Environ.push_context_set ~strict:true ctx env in let rec translate_seff sl seff acc env = @@ -737,7 +727,12 @@ let export_side_effects mb env (b_ctx, eff) = let kn = eff.seff_constant in let ce = constant_entry_of_side_effect eff in let cb = Term_typing.translate_constant Term_typing.Pure env kn ce in - let cb = map_constant Future.force cb in + let map cu = + let (c, u) = Future.force cu in + let () = assert (Univ.ContextSet.is_empty u) in + c + in + let cb = map_constant map cb in let eff = { eff with seff_body = cb } in (push_seff env eff, export_eff eff) in @@ -749,9 +744,13 @@ let export_side_effects mb env (b_ctx, eff) = in translate_seff trusted seff [] env +let n_univs cb = match cb.const_universes with +| Monomorphic _ -> 0 +| Polymorphic auctx -> Univ.AUContext.size auctx + let export_private_constants ~in_section ce senv = let exported, ce = export_side_effects senv.revstruct senv.env ce in - let map (kn, cb, _) = (kn, map_constant (fun p -> Opaqueproof.create (Future.from_val p)) cb) in + let map (kn, cb, _) = (kn, map_constant (fun p -> Opaqueproof.create ~univs:(n_univs cb) (Future.from_val (p, Univ.ContextSet.empty))) cb) in let bodies = List.map map exported in let exported = List.map (fun (kn, _, r) -> (kn, r)) exported in let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in @@ -778,7 +777,7 @@ let add_constant ?role ~in_section l decl senv = Term_typing.translate_constant Term_typing.Pure senv.env kn ce in let senv = - let cb = map_constant Opaqueproof.create cb in + let cb = map_constant (fun c -> Opaqueproof.create ~univs:(n_univs cb) c) cb in add_constant_aux ~in_section senv (kn, cb) in let senv = match decl with @@ -790,7 +789,20 @@ let add_constant ?role ~in_section l decl senv = let eff = match role with | None -> empty_private_constants | Some role -> - let cb = map_constant Future.force cb in + let body, univs = match cb.const_body with + | (Primitive _ | Undef _) -> assert false + | Def c -> (Def c, cb.const_universes) + | OpaqueDef o -> + let (b, ctx) = Future.force o in + match cb.const_universes with + | Monomorphic ctx' -> + OpaqueDef b, Monomorphic (Univ.ContextSet.union ctx ctx') + | Polymorphic auctx -> + (* Upper layers enforce that there are no internal constraints *) + let () = assert (Univ.ContextSet.is_empty ctx) in + OpaqueDef b, Polymorphic auctx + in + let cb = { cb with const_body = body; const_universes = univs } in let from_env = CEphemeron.create senv.revstruct in let eff = { from_env = from_env; diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 088dd98db8..f984088f47 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -115,16 +115,8 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = } (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, - so we delay the typing and hash consing of its body. - Remark: when the universe quantification is given explicitly, we could - delay even in the polymorphic case. *) + so we delay the typing and hash consing of its body. *) -(** Definition is opaque (Qed) and non polymorphic with known type, so we delay -the typing and hash consing of its body. - -TODO: if the universe quantification is given explicitly, we could delay even in -the polymorphic case - *) | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; const_entry_universes = Monomorphic_entry univs; _ } as c) -> @@ -165,16 +157,59 @@ the polymorphic case cook_context = c.const_entry_secctx; } + (** Similar case for polymorphic entries. TODO: also delay type-checking of + the body. *) + + | DefinitionEntry ({ const_entry_type = Some typ; + const_entry_opaque = true; + const_entry_universes = Polymorphic_entry (nas, uctx); _ } as c) -> + let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in + let env = push_context ~strict:false uctx env in + let tj = Typeops.infer_type env typ in + let sbst, auctx = Univ.abstract_universes nas uctx in + let usubst = Univ.make_instance_subst sbst in + let (def, private_univs) = + let (body, ctx), side_eff = Future.join body in + let body, ctx = match trust with + | Pure -> body, ctx + | SideEffects handle -> + let body, ctx', _ = handle env body side_eff in + body, Univ.ContextSet.union ctx ctx' + in + (** [ctx] must contain local universes, such that it has no impact + on the rest of the graph (up to transitivity). *) + let env = push_subgraph ctx env in + let private_univs = on_snd (Univ.subst_univs_level_constraints usubst) ctx in + let j = Typeops.infer env body in + let _ = Typeops.judge_of_cast env j DEFAULTcast tj in + let def = Vars.subst_univs_level_constr usubst j.uj_val in + def, private_univs + in + let def = OpaqueDef (Future.from_val (def, Univ.ContextSet.empty)) in + let typ = Vars.subst_univs_level_constr usubst tj.utj_val in + feedback_completion_typecheck feedback_id; + { + Cooking.cook_body = def; + cook_type = typ; + cook_universes = Polymorphic auctx; + cook_private_univs = Some private_univs; + cook_relevance = Sorts.relevance_of_sort tj.utj_type; + cook_inline = c.const_entry_inline_code; + cook_context = c.const_entry_secctx; + } + (** Other definitions have to be processed immediately. *) | DefinitionEntry c -> - let { const_entry_type = typ; const_entry_opaque = opaque ; _ } = c in + let { const_entry_type = typ; _ } = c in let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in - let (body, ctx), side_eff = Future.join body in + (* Opaque constants must be provided with a non-empty const_entry_type, + and thus should have been treated above. *) + let () = assert (not c.const_entry_opaque) in let body, ctx = match trust with - | Pure -> body, ctx - | SideEffects handle -> - let body, ctx', _ = handle env body side_eff in - body, Univ.ContextSet.union ctx ctx' + | Pure -> + let (body, ctx), () = Future.join body in + body, ctx + | SideEffects _ -> assert false in let env, usubst, univs, private_univs = match c.const_entry_universes with | Monomorphic_entry univs -> @@ -188,9 +223,6 @@ the polymorphic case let sbst, auctx = Univ.abstract_universes nas uctx in let sbst = Univ.make_instance_subst sbst in let env, local = - if opaque then - push_subgraph ctx env, Some (on_snd (Univ.subst_univs_level_constraints sbst) ctx) - else if Univ.ContextSet.is_empty ctx then env, None else CErrors.anomaly Pp.(str "Local universes in non-opaque polymorphic definition.") in @@ -206,10 +238,7 @@ the polymorphic case Vars.subst_univs_level_constr usubst tj.utj_val in let def = Vars.subst_univs_level_constr usubst j.uj_val in - let def = - if opaque then OpaqueDef (Future.from_val (def, Univ.ContextSet.empty)) - else Def (Mod_subst.from_val def) - in + let def = Def (Mod_subst.from_val def) in feedback_completion_typecheck feedback_id; { Cooking.cook_body = def; diff --git a/kernel/uint63_amd64.ml b/kernel/uint63_amd64_63.ml index 2d4d685775..2d4d685775 100644 --- a/kernel/uint63_amd64.ml +++ b/kernel/uint63_amd64_63.ml diff --git a/kernel/uint63_x86.ml b/kernel/uint63_i386_31.ml index fa45c90241..fa45c90241 100644 --- a/kernel/uint63_x86.ml +++ b/kernel/uint63_i386_31.ml diff --git a/kernel/write_uint63.ml b/kernel/write_uint63.ml index beb59ce205..42bb5dfbb1 100644 --- a/kernel/write_uint63.ml +++ b/kernel/write_uint63.ml @@ -31,8 +31,8 @@ let ml_file_copy input output = let write_uint63 () = ml_file_copy - (if max_int = 1073741823 (* 32-bits *) then "uint63_x86.ml" - else (* 64 bits *) "uint63_amd64.ml") + (if max_int = 1073741823 (* 32-bits *) then "uint63_i386_31.ml" + else (* 64 bits *) "uint63_amd64_63.ml") "uint63.ml" let () = write_uint63 () diff --git a/library/lib.ml b/library/lib.ml index 4be288ed20..daa41eca65 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -474,9 +474,6 @@ let extract_hyps (secs,ohyps) = let instance_from_variable_context = List.map fst %> List.filter is_local_assum %> List.map NamedDecl.get_id %> Array.of_list -let named_of_variable_context = - List.map fst - let name_instance inst = (* FIXME: this should probably be done at an upper level, by storing the name information in the section data structure. *) diff --git a/library/lib.mli b/library/lib.mli index 5da76961a6..c19c3bf7fa 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -168,7 +168,6 @@ type abstr_info = private { } val instance_from_variable_context : variable_context -> Id.t array -val named_of_variable_context : variable_context -> Constr.named_context val section_segment_of_constant : Constant.t -> abstr_info val section_segment_of_mutual_inductive: MutInd.t -> abstr_info diff --git a/library/library.ml b/library/library.ml index e3b8511af1..1ac75d2fdc 100644 --- a/library/library.ml +++ b/library/library.ml @@ -276,11 +276,11 @@ let in_import_library : DirPath.t list * bool -> obj = (** Delayed / available tables of opaque terms *) type 'a table_status = - | ToFetch of 'a option array delayed - | Fetched of 'a option array + | ToFetch of 'a array delayed + | Fetched of 'a array let opaque_tables = - ref (LibraryMap.empty : (Constr.constr table_status) LibraryMap.t) + ref (LibraryMap.empty : ((Opaqueproof.cooking_info list * int * Constr.constr option) table_status) LibraryMap.t) let add_opaque_table dp st = opaque_tables := LibraryMap.add dp st !opaque_tables @@ -306,10 +306,14 @@ let access_table what tables dp i = let access_opaque_table dp i = let what = "opaque proofs" in - access_table what opaque_tables dp i + let (info, n, c) = access_table what opaque_tables dp i in + match c with + | None -> None + | Some c -> Some (Cooking.cook_constr info n c) let indirect_accessor = { Opaqueproof.access_proof = access_opaque_table; + Opaqueproof.access_discharge = Cooking.cook_constr; } (************************************************************************) @@ -319,8 +323,7 @@ type seg_sum = summary_disk type seg_lib = library_disk type seg_univ = (* true = vivo, false = vi *) Univ.ContextSet.t * bool -type seg_discharge = Opaqueproof.cooking_info list array -type seg_proofs = Constr.constr option array +type seg_proofs = (Opaqueproof.cooking_info list * int * Constr.t option) array let mk_library sd md digests univs = { @@ -344,7 +347,6 @@ let intern_from_file f = let ((lmd : seg_lib delayed), digest_lmd) = in_delayed f ch in let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in let _ = System.skip_in_segment f ch in - let _ = System.skip_in_segment f ch in let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch in close_in ch; register_library_filename lsd.md_name f; @@ -527,15 +529,13 @@ let load_library_todo f = let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in let (s2 : seg_univ option), _, _ = System.marshal_in_segment f ch in - let (s3 : seg_discharge option), _, _ = System.marshal_in_segment f ch in let tasks, _, _ = System.marshal_in_segment f ch in - let (s5 : seg_proofs), _, _ = System.marshal_in_segment f ch in + let (s4 : seg_proofs), _, _ = System.marshal_in_segment f ch in close_in ch; if tasks = None then user_err ~hdr:"restart" (str"not a .vio file"); if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); - if s3 = None then user_err ~hdr:"restart" (str"not a .vio file"); if snd (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); - s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 + s0, s1, Option.get s2, Option.get tasks, s4 (************************************************************************) (*s [save_library dir] ends library [dir] and save it to the disk. *) @@ -578,10 +578,10 @@ let save_library_to ?todo ~output_native_objects dir f otab = List.fold_left (fun e (r,_) -> Future.UUIDSet.add r.Stateid.uuid e) Future.UUIDSet.empty l in let cenv, seg, ast = Declaremods.end_library ~output_native_objects ~except dir in - let opaque_table, disch_table, f2t_map = Opaqueproof.dump ~except otab in - let tasks, utab, dtab = + let opaque_table, f2t_map = Opaqueproof.dump ~except otab in + let tasks, utab = match todo with - | None -> None, None, None + | None -> None, None | Some (tasks, rcbackup) -> let tasks = List.map Stateid.(fun (r,b) -> @@ -589,8 +589,8 @@ let save_library_to ?todo ~output_native_objects dir f otab = with Not_found -> assert b; { r with uuid = -1 }, b) tasks in Some (tasks,rcbackup), - Some (Univ.ContextSet.empty,false), - Some disch_table in + Some (Univ.ContextSet.empty,false) + in let sd = { md_name = dir; md_deps = Array.of_list (current_deps ()); @@ -610,7 +610,6 @@ let save_library_to ?todo ~output_native_objects dir f otab = System.marshal_out_segment f' ch (sd : seg_sum); System.marshal_out_segment f' ch (md : seg_lib); System.marshal_out_segment f' ch (utab : seg_univ option); - System.marshal_out_segment f' ch (dtab : seg_discharge option); System.marshal_out_segment f' ch (tasks : 'tasks option); System.marshal_out_segment f' ch (opaque_table : seg_proofs); close_out ch; @@ -630,7 +629,6 @@ let save_library_raw f sum lib univs proofs = System.marshal_out_segment f ch (sum : seg_sum); System.marshal_out_segment f ch (lib : seg_lib); System.marshal_out_segment f ch (Some univs : seg_univ option); - System.marshal_out_segment f ch (None : seg_discharge option); System.marshal_out_segment f ch (None : 'tasks option); System.marshal_out_segment f ch (proofs : seg_proofs); close_out ch diff --git a/library/library.mli b/library/library.mli index 142206e2c5..727eca10cf 100644 --- a/library/library.mli +++ b/library/library.mli @@ -35,8 +35,7 @@ type seg_sum type seg_lib type seg_univ = (* all_cst, finished? *) Univ.ContextSet.t * bool -type seg_discharge = Opaqueproof.cooking_info list array -type seg_proofs = Constr.constr option array +type seg_proofs = (Opaqueproof.cooking_info list * int * Constr.t option) array (** Open a module (or a library); if the boolean is true then it's also an export otherwise just a simple import *) @@ -51,7 +50,7 @@ val save_library_to : val load_library_todo : CUnix.physical_path - -> seg_sum * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs + -> seg_sum * seg_lib * seg_univ * 'tasks * seg_proofs val save_library_raw : string -> seg_sum -> seg_lib -> seg_univ -> seg_proofs -> unit diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index bd88570224..79cfe33b12 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -133,7 +133,8 @@ let aliasvar = function { CAst.v = CPatAlias (_, na) } -> Some na | _ -> None } GRAMMAR EXTEND Gram - GLOBAL: binder_constr lconstr constr operconstr universe_level sort sort_family + GLOBAL: binder_constr lconstr constr operconstr + universe_level universe_name sort sort_family global constr_pattern lconstr_pattern Constr.ident closed_binder open_binders binder binders binders_fixannot record_declaration typeclass_constraint pattern appl_arg; @@ -153,11 +154,12 @@ GRAMMAR EXTEND Gram [ [ c = lconstr -> { c } ] ] ; sort: - [ [ "Set" -> { GSet } - | "Prop" -> { GProp } - | "SProp" -> { GSProp } - | "Type" -> { GType [] } - | "Type"; "@{"; u = universe; "}" -> { GType u } + [ [ "Set" -> { UNamed [GSet,0] } + | "Prop" -> { UNamed [GProp,0] } + | "SProp" -> { UNamed [GSProp,0] } + | "Type" -> { UAnonymous {rigid=true} } + | "Type"; "@{"; "_"; "}" -> { UAnonymous {rigid=false} } + | "Type"; "@{"; u = universe; "}" -> { UNamed u } ] ] ; sort_family: @@ -167,11 +169,17 @@ GRAMMAR EXTEND Gram | "Type" -> { Sorts.InType } ] ] ; + universe_increment: + [ [ "+"; n = natural -> { n } + | -> { 0 } ] ] + ; + universe_name: + [ [ id = global -> { GType id } + | "Set" -> { GSet } + | "Prop" -> { GProp } ] ] + ; universe_expr: - [ [ id = global; "+"; n = natural -> { Some (id,n) } - | id = global -> { Some (id,0) } - | "_" -> { None } - ] ] + [ [ id = universe_name; n = universe_increment -> { (id,n) } ] ] ; universe: [ [ IDENT "max"; "("; ids = LIST1 universe_expr SEP ","; ")" -> { ids } @@ -328,12 +336,12 @@ GRAMMAR EXTEND Gram | -> { None } ] ] ; universe_level: - [ [ "Set" -> { GSet } + [ [ "Set" -> { UNamed GSet } (* no parsing SProp as a level *) - | "Prop" -> { GProp } - | "Type" -> { GType UUnknown } - | "_" -> { GType UAnonymous } - | id = global -> { GType (UNamed id) } + | "Prop" -> { UNamed GProp } + | "Type" -> { UAnonymous {rigid=true} } + | "_" -> { UAnonymous {rigid=false} } + | id = global -> { UNamed (GType id) } ] ] ; fix_constr: diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b474c8e9a9..b375c526ad 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -427,6 +427,7 @@ module Constr = let binder_constr = gec_constr "binder_constr" let ident = make_gen_entry uconstr "ident" let global = make_gen_entry uconstr "global" + let universe_name = make_gen_entry uconstr "universe_name" let universe_level = make_gen_entry uconstr "universe_level" let sort = make_gen_entry uconstr "sort" let sort_family = make_gen_entry uconstr "sort_family" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 5f982346ab..196835f184 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -182,6 +182,7 @@ module Constr : val operconstr : constr_expr Entry.t val ident : Id.t Entry.t val global : qualid Entry.t + val universe_name : Glob_term.glob_sort_name Entry.t val universe_level : Glob_term.glob_level Entry.t val sort : Glob_term.glob_sort Entry.t val sort_family : Sorts.family Entry.t 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/g_derive.mlg b/plugins/derive/g_derive.mlg index 214a9d8bb5..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 } -| ![ proof ] [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - { fun ~pstate -> Some Derive.(start_deriving f suchthat 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/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..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.t option -> unit +val show_extraction : pstate:Proof_global.t -> unit diff --git a/plugins/extraction/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index db1a389fe7..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 ] [ "Show" "Extraction" ] - -> { fun ~pstate -> let () = show_extraction ~pstate in pstate } +VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY STATE proof_query +| [ "Show" "Extraction" ] + -> { show_extraction } 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..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 -| ![ 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 - | _,((_,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) } +VERNAC COMMAND EXTEND Function STATE CUSTOM +| ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] + => { 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 { @@ -225,33 +242,32 @@ let warning_error names e = } VERNAC COMMAND EXTEND NewFunctionalScheme -| ![ proof ] ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] +| ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] => { Vernacextend.(VtSideff(List.map pi1 fas), VtLater) } -> - { fun ~pstate -> - begin + { begin try - Functional_principles_types.build_scheme fas; pstate + Functional_principles_types.build_scheme fas 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 + 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; pstate + warning_error names e end } END @@ -265,6 +281,6 @@ END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY -| ![ proof ] ["Generate" "graph" "for" reference(c)] -> +| ["Generate" "graph" "for" reference(c)] -> { make_graph (Smartlocate.global_with_alias c) } END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 4c67d65816..201d953692 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1299,10 +1299,10 @@ let rec rebuild_return_type rt = | Constrexpr.CProdN(n,t') -> CAst.make ?loc @@ Constrexpr.CProdN(n,rebuild_return_type t') | Constrexpr.CLetIn(na,v,t,t') -> - CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') + CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') | _ -> CAst.make ?loc @@ Constrexpr.CProdN([Constrexpr.CLocalAssum ([CAst.make Anonymous], Constrexpr.Default Decl_kinds.Explicit, rt)], - CAst.make @@ Constrexpr.CSort(GType [])) + CAst.make @@ Constrexpr.CSort(UAnonymous {rigid=true})) let do_build_inductive evd (funconstants: pconstant list) (funsargs: (Name.t * glob_constr * glob_constr option) list list) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index a6b088de0c..241da053b7 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 + 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 ~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 generate_correction_proof_wf f_ref tcc_lemma_ref @@ -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 ~pstate 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,8 +660,8 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive 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 - else pstate, 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 = match recompute_binder_list [fixpoint_expr] with @@ -684,8 +684,8 @@ let do_generate_principle ~pstate pconstants on_error register_built interactive 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 - else pstate, 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) -> 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,9 @@ 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 (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 -> @@ -902,11 +902,27 @@ 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_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; - pstate) - -let do_generate_principle = do_generate_principle [] warning_error true + expr_list) + +(* *************** 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 acf85f539e..1ba245a45d 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -5,10 +5,12 @@ 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 -> - bool -> +val do_generate_principle : + (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 -> @@ -17,4 +19,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 : GlobRef.t -> unit 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 216be3797b..e2321d233c 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 @@ -1396,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 + 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 @@ -1413,7 +1410,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 +1428,8 @@ let com_terminate with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - defined pstate + 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 = @@ -1459,7 +1457,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,14 +1487,12 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation } ) )) pstate in - (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) -(* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) - 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 +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 @@ -1587,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 a006c2c354..b92ac3a0ec 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -5,15 +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 - +val recursive_definition : + 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/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 4c186dce09..0ded60d9c7 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -931,10 +931,10 @@ 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 -> 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. *) @@ -963,10 +963,10 @@ 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 -> 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.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..960e5b76f8 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 @@ -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 - 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) ] => +| [ "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 @@ -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 de3a9c9fa9..58c8dabd79 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 (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 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) ] -> +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 } -| ![ proof ] [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> +| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> { obligation (num, Some name, None) tac } -| ![ proof ] [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> +| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> { obligation (num, None, Some t) tac } -| ![ proof ] [ "Obligation" integer(num) withtac(tac) ] -> +| [ "Obligation" integer(num) withtac(tac) ] -> { obligation (num, None, None) tac } -| ![ proof ] [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> +| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> { next_obligation (Some name) tac } -| ![ 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/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 2fad1f6b6a..1a84158df7 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,65 +234,63 @@ 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) ] - (* 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; ] ![ proof ] [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(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 - } - | #[ 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 164bd7e118..e0a31e7dba 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 @@ -43,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. *) @@ -947,9 +946,9 @@ let fold_match ?(force=false) env sigma c = if dep then case_dep_scheme_kind_from_prop else case_scheme_kind_from_prop else ( - if dep - then case_dep_scheme_kind_from_type_in_prop - else case_scheme_kind_from_type) + if dep + then case_dep_scheme_kind_from_type_in_prop + else case_scheme_kind_from_type) else ((* sortc <> InProp by typing *) if dep then case_dep_scheme_kind_from_type @@ -1795,15 +1794,16 @@ 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 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 anew_instance atts binders (name,t) fields = + 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 + () -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 = @@ -1816,44 +1816,44 @@ 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 - | (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) -> () + | (Some lemma1, None, None) -> + declare_instance_refl atts binders a aeq n lemma1 + | (None, Some lemma2, None) -> + declare_instance_sym atts binders a aeq n lemma2 + | (None, None, Some lemma3) -> + declare_instance_trans atts binders a aeq n lemma3 + | (Some lemma1, Some lemma2, None) -> + 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 () = 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 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 () = 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 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 () = 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 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) @@ -1949,18 +1949,18 @@ 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 _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 () = 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 - 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 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 = @@ -1972,45 +1972,48 @@ 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_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 (); - (* 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 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 - 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 - 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 -> - 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 ~ontop:pstate ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in - Some (fst Pfedit.(by (Tacinterp.interp tac) pstate))) () + 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 + 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 @@ -2020,12 +2023,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 - ~program_mode:atts.program ~global:atts.global atts.polymorphic - instance_name binders instance_t None + let _id, pstate = Classes.new_instance_interactive + ~global:atts.global atts.polymorphic + instance_name binders instance_t ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in - pstate + pstate (* no instance body -> always open proof *) (** Bind to "rewrite" too *) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index a200cb5ced..3ef33c6dc9 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -81,18 +81,36 @@ 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 add_morphism_infer : pstate:Proof_global.t option -> rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t 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 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_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 + -> local_binder_expr list + -> constr_expr + -> constr_expr + -> Id.t + -> Proof_global.t val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index aeceeb4e50..8e7b045b8e 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -153,9 +153,11 @@ let decl_constant na univs c = let open Constr in let vars = CVars.universes_of_constr c in let univs = UState.restrict_universe_context univs vars in - let univs = Monomorphic_entry univs in + let () = Declare.declare_universe_context false univs in + let types = (Typeops.infer (Global.env ()) c).uj_type in + let univs = Monomorphic_entry Univ.ContextSet.empty in mkConst(declare_constant (Id.of_string na) - (DefinitionEntry (definition_entry ~opaque:true ~univs c), + (DefinitionEntry (definition_entry ~opaque:true ~types ~univs c), IsProof Lemma)) (* Calling a global tactic *) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 56f17703ff..6c7b4702b6 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -194,8 +194,8 @@ let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) let mkRVar id = DAst.make @@ GRef (VarRef id,None) let mkRltacVar id = DAst.make @@ GVar (id) let mkRCast rc rt = DAst.make @@ GCast (rc, CastConv rt) -let mkRType = DAst.make @@ GSort (GType []) -let mkRProp = DAst.make @@ GSort (GProp) +let mkRType = DAst.make @@ GSort (UAnonymous {rigid=true}) +let mkRProp = DAst.make @@ GSort (UNamed [GProp,0]) let mkRArrow rt1 rt2 = DAst.make @@ GProd (Anonymous, Explicit, rt1, rt2) let mkRConstruct c = DAst.make @@ GRef (ConstructRef c,None) let mkRInd mind = DAst.make @@ GRef (IndRef mind,None) @@ -871,8 +871,8 @@ open Constrexpr open Util (** Constructors for constr_expr *) -let mkCProp loc = CAst.make ?loc @@ CSort GProp -let mkCType loc = CAst.make ?loc @@ CSort (GType []) +let mkCProp loc = CAst.make ?loc @@ CSort (UNamed [GProp,0]) +let mkCType loc = CAst.make ?loc @@ CSort (UAnonymous {rigid=true}) let mkCVar ?loc id = CAst.make ?loc @@ CRef (qualid_of_ident ?loc id, None) let rec mkCHoles ?loc n = if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, Namegen.IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) @@ -1119,6 +1119,7 @@ let cleartac clr = check_hyps_uniq [] clr; Tactics.clear (hyps_ids clr) (* XXX the k of the redex should percolate out *) let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = let pat = interp_cpattern gl t None in (* UGLY API *) + let gl = pf_merge_uc_of (fst pat) gl in let cl, env, sigma = Tacmach.pf_concl gl, pf_env gl, project gl in let (c, ucst), cl = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr cl) pat occ 1 @@ -1253,6 +1254,7 @@ let abs_wgen keep_let f gen (gl,args,c) = | _, Some ((x, "@"), Some p) -> let x = hoi_id x in let cp = interp_cpattern gl p None in + let gl = pf_merge_uc_of (fst cp) gl in let (t, ucst), c = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 with NoMatch -> redex_of_pattern env cp, (EConstr.Unsafe.to_constr c) in @@ -1265,6 +1267,7 @@ let abs_wgen keep_let f gen (gl,args,c) = | _, Some ((x, _), Some p) -> let x = hoi_id x in let cp = interp_cpattern gl p None in + let gl = pf_merge_uc_of (fst cp) gl in let (t, ucst), c = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 with NoMatch -> redex_of_pattern env cp, (EConstr.Unsafe.to_constr c) in diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index dbc9bb24c5..3a0868b7e4 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -383,15 +383,22 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let c = fire_subst gl (List.assoc (n_elim_args - k - 1) elim_args) in let gl, t = pfe_type_of gl c in let gl, eq = get_eq_type gl in - let gen_eq_tac, gl = + let gen_eq_tac, eq_ty, gl = let refl = EConstr.mkApp (eq, [|t; c; c|]) in let new_concl = EConstr.mkArrow refl Sorts.Relevant (EConstr.Vars.lift 1 (pf_concl orig_gl)) in let new_concl = fire_subst gl new_concl in let erefl, gl = mkRefl t c gl in let erefl = fire_subst gl erefl in - apply_type new_concl [erefl], gl in + let erefl_ty = Retyping.get_type_of (pf_env gl) (project gl) erefl in + let eq_ty = Retyping.get_type_of (pf_env gl) (project gl) erefl_ty in + let gen_eq_tac s = + let open Evd in + let sigma = merge_universe_context s.sigma (evar_universe_context (project gl)) in + apply_type new_concl [erefl] { s with sigma } + in + gen_eq_tac, eq_ty, gl in let rel = k + if c_is_head_p then 1 else 0 in - let src, gl = mkProt EConstr.mkProp EConstr.(mkApp (eq,[|t; c; mkRel rel|])) gl in + let src, gl = mkProt eq_ty EConstr.(mkApp (eq,[|t; c; mkRel rel|])) gl in let concl = EConstr.mkArrow src Sorts.Relevant (EConstr.Vars.lift 1 concl) in let clr = if deps <> [] then clr else [] in concl, gen_eq_tac, clr, gl diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 538d0c4e9a..91905d277c 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -336,14 +336,14 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ let sigma, p = (* The resulting goal *) Evarutil.new_evar env sigma (beta (EConstr.Vars.subst1 new_rdx pred)) in let pred = EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdx_ty pred in - let elim, gl = + let elim, gl = let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in let sort = elimination_sort_of_goal gl in let elim, gl = pf_fresh_global (Indrec.lookup_eliminator env ind sort) gl in if dir = R2L then elim, gl else (* taken from Coq's rewrite *) let elim, _ = destConst elim in let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical elim)) in - let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in + let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make2 mp l')) in mkConst c1', gl in let elim = EConstr.of_constr elim in @@ -619,7 +619,11 @@ let rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt) with _ when snd mult = May -> fail := true; (project gl, EConstr.mkProp) in let rwtac gl = let rx = Option.map (interp_rpattern gl) grx in + let gl = match rx with + | None -> gl + | Some (s,_) -> pf_merge_uc_of s gl in let t = interp gt gl in + let gl = pf_merge_uc_of (fst t) gl in (match kind with | RWred sim -> simplintac occ rx sim | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 27a558611e..62d344cc02 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -79,7 +79,6 @@ let pr_ssrtacarg env sigma _ _ prt = prt env sigma tacltop } ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } -| [ "YouShouldNotTypeThis" ] -> { CErrors.anomaly (Pp.str "Grammar placeholder match") } END GRAMMAR EXTEND Gram GLOBAL: ssrtacarg; @@ -88,7 +87,6 @@ END (* Copy of ssrtacarg with LEVEL "3", useful for: "under ... do ..." *) ARGUMENT EXTEND ssrtac3arg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } -| [ "YouShouldNotTypeThis" ] -> { CErrors.anomaly (Pp.str "Grammar placeholder match") } END GRAMMAR EXTEND Gram GLOBAL: ssrtac3arg; @@ -204,17 +202,6 @@ ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY { pr_ssrhoi } | [ ident(id) ] -> { Id (SsrHyp(Loc.tag ~loc id)) } END -{ - -let pr_ssrhyps _ _ _ = pr_hyps - -} - -ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY { pr_ssrhyps } - INTERPRETED BY { interp_hyps } - | [ ssrhyp_list(hyps) ] -> { check_hyps_uniq [] hyps; hyps } -END - (** Rewriting direction *) { @@ -310,18 +297,13 @@ GRAMMAR EXTEND Gram END -ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY { pr_ssrsimpl } -| [ ssrsimpl_ne(sim) ] -> { sim } -| [ ] -> { Nop } -END - { let pr_ssrclear _ _ _ = pr_clear mt } -ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY { pr_ssrclear } +ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyp list PRINTED BY { pr_ssrclear } | [ "{" ne_ssrhyp_list(clr) "}" ] -> { check_hyps_uniq [] clr; clr } END @@ -1005,7 +987,6 @@ let pr_ssrfwdidx _ _ _ = pr_ssrfwdid (* We use a primitive parser for the head identifier of forward *) (* tactis to avoid syntactic conflicts with basic Coq tactics. *) ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY { pr_ssrfwdidx } - | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END { @@ -1564,7 +1545,6 @@ let pr_ssrdoarg env sigma prc _ prt (((n, m), tac), clauses) = ARGUMENT EXTEND ssrdoarg TYPED AS (((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses) PRINTED BY { pr_ssrdoarg env sigma } -| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END { @@ -1587,7 +1567,7 @@ let pr_ssrseqarg env sigma _ _ prt = function (* an unindexed tactic. *) ARGUMENT EXTEND ssrseqarg TYPED AS (ssrindex * (ssrhintarg * tactic option)) PRINTED BY { pr_ssrseqarg env sigma } -| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } + END { @@ -1867,7 +1847,6 @@ let pr_ssrseqdir _ _ _ = function } ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY { pr_ssrseqdir } -| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END TACTIC EXTEND ssrtclseq @@ -2004,7 +1983,6 @@ let pr_ssreqid _ _ _ = pr_eqid (* We must use primitive parsing here to avoid conflicts with the *) (* basic move, case, and elim tactics. *) ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY { pr_ssreqid } -| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END { @@ -2326,7 +2304,6 @@ let noruleterm loc = mk_term xNoFlag (mkCProp loc) } ARGUMENT EXTEND ssrrule_ne TYPED AS (ssrrwkind * ssrterm) PRINTED BY { pr_ssrrule } - | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END GRAMMAR EXTEND Gram @@ -2413,7 +2390,6 @@ let pr_ssrrwargs _ _ _ rwargs = pr_list spc pr_rwarg rwargs } ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list PRINTED BY { pr_ssrrwargs } - | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END { diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 82726eccf0..18a036cb8c 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -688,20 +688,21 @@ let hack_qualid_of_univ_level sigma l = let detype_universe sigma u = let fn (l, n) = - let qid = hack_qualid_of_univ_level sigma l in - Some (qid, n) - in + let s = + if Univ.Level.is_prop l then GProp else + if Univ.Level.is_set l then GSet else + GType (hack_qualid_of_univ_level sigma l) in + (s, n) in Univ.Universe.map fn u let detype_sort sigma = function - | SProp -> GSProp - | Prop -> GProp - | Set -> GSet + | SProp -> UNamed [GSProp,0] + | Prop -> UNamed [GProp,0] + | Set -> UNamed [GSet,0] | Type u -> - GType (if !print_universes - then detype_universe sigma u - else []) + then UNamed (detype_universe sigma u) + else UAnonymous {rigid=true}) type binder_kind = BProd | BLambda | BLetIn @@ -710,7 +711,7 @@ type binder_kind = BProd | BLambda | BLetIn let detype_level sigma l = let l = hack_qualid_of_univ_level sigma l in - GType (UNamed l) + UNamed (GType l) let detype_instance sigma l = let l = EInstance.kind sigma l in diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 85b9faac77..a3a3c7f811 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -45,20 +45,27 @@ let map_glob_decl_left_to_right f (na,k,obd,ty) = let comp2 = f ty in (na,k,comp1,comp2) +let glob_sort_name_eq g1 g2 = match g1, g2 with + | GSProp, GSProp + | GProp, GProp + | GSet, GSet -> true + | GType u1, GType u2 -> Libnames.qualid_eq u1 u2 + | (GSProp|GProp|GSet|GType _), _ -> false -let glob_sort_eq g1 g2 = let open Glob_term in match g1, g2 with -| GSProp, GSProp -| GProp, GProp -| GSet, GSet -> true -| GType l1, GType l2 -> - List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.qualid_eq x y && Int.equal m n)) l1 l2 -| (GSProp|GProp|GSet|GType _), _ -> false +exception ComplexSort let glob_sort_family = let open Sorts in function -| GSProp -> InSProp -| GProp -> InProp -| GSet -> InSet -| GType _ -> InType + | UAnonymous {rigid=true} -> InType + | UNamed [GSProp,0] -> InProp + | UNamed [GProp,0] -> InProp + | UNamed [GSet,0] -> InSet + | _ -> raise ComplexSort + +let glob_sort_eq u1 u2 = match u1, u2 with + | UAnonymous {rigid=r1}, UAnonymous {rigid=r2} -> r1 = r2 + | UNamed l1, UNamed l2 -> + List.equal (fun (x,m) (y,n) -> glob_sort_name_eq x y && Int.equal m n) l1 l2 + | (UNamed _ | UAnonymous _), _ -> false let binding_kind_eq bk1 bk2 = match bk1, bk2 with | Decl_kinds.Explicit, Decl_kinds.Explicit -> true diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index df902a8fa7..3995ab6a5a 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -15,10 +15,13 @@ open Glob_term val glob_sort_eq : Glob_term.glob_sort -> Glob_term.glob_sort -> bool -val glob_sort_family : 'a glob_sort_gen -> Sorts.family - val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool +(** Expect a Prop/SProp/Set/Type universe; raise [ComplexSort] if + contains a max, an increment, or a flexible universe *) +exception ComplexSort +val glob_sort_family : glob_sort -> Sorts.family + val alias_of_pat : 'a cases_pattern_g -> Name.t val set_pat_alias : Id.t -> 'a cases_pattern_g -> 'a cases_pattern_g diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index 02cb294f6d..704cddd784 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -23,23 +23,23 @@ type existential_name = Id.t (** Sorts *) -type 'a glob_sort_gen = +type glob_sort_name = | GSProp (** representation of [SProp] literal *) - | GProp (** representation of [Prop] literal *) - | GSet (** representation of [Set] literal *) - | GType of 'a (** representation of [Type] literal *) + | GProp (** representation of [Prop] level *) + | GSet (** representation of [Set] level *) + | GType of Libnames.qualid (** representation of a [Type] level *) -type 'a universe_kind = - | UAnonymous - | UUnknown +type 'a glob_sort_expr = + | UAnonymous of { rigid : bool } (** not rigid = unifiable by minimization *) | UNamed of 'a -type level_info = Libnames.qualid universe_kind -type glob_level = level_info glob_sort_gen -type glob_constraint = glob_level * Univ.constraint_type * glob_level +(** levels, occurring in universe instances *) +type glob_level = glob_sort_name glob_sort_expr -type sort_info = (Libnames.qualid * int) option list -type glob_sort = sort_info glob_sort_gen +(** sort expressions *) +type glob_sort = (glob_sort_name * int) list glob_sort_expr + +type glob_constraint = glob_sort_name * Univ.constraint_type * glob_sort_name type glob_recarg = int option diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index c788efda48..2d27b27cab 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -410,7 +410,9 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PLetIn (na, pat_of_raw metas vars c1, Option.map (pat_of_raw metas vars) t, pat_of_raw metas (na::vars) c2) - | GSort gs -> PSort (Glob_ops.glob_sort_family gs) + | GSort gs -> + (try PSort (Glob_ops.glob_sort_family gs) + with Glob_ops.ComplexSort -> user_err ?loc (str "Unexpected universe in pattern.")) | GHole _ -> PMeta None | GCast (c,_) -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index f2b8671a48..be8f7215fa 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -52,6 +52,18 @@ type typing_constraint = OfType of types | IsType | WithoutTypeConstraint let (!!) env = GlobEnv.env env +let bidi_hints = + Summary.ref (GlobRef.Map.empty : int GlobRef.Map.t) ~name:"bidirectionalityhints" + +let add_bidirectionality_hint gr n = + bidi_hints := GlobRef.Map.add gr n !bidi_hints + +let get_bidirectionality_hint gr = + GlobRef.Map.find_opt gr !bidi_hints + +let clear_bidirectionality_hint gr = + bidi_hints := GlobRef.Map.remove gr !bidi_hints + (************************************************************************) (* This concerns Cases *) open Inductive @@ -120,7 +132,7 @@ let is_strict_universe_declarations = (** Miscellaneous interpretation functions *) -let interp_known_universe_level evd qid = +let interp_known_universe_level_name evd qid = try let open Libnames in if qualid_is_ident qid then Evd.universe_of_name evd @@ qualid_basename qid @@ -130,7 +142,7 @@ let interp_known_universe_level evd qid = Univ.Level.make qid let interp_universe_level_name ~anon_rigidity evd qid = - try evd, interp_known_universe_level evd qid + try evd, interp_known_universe_level_name evd qid with Not_found -> if Libnames.qualid_is_ident qid then (* Undeclared *) let id = Libnames.qualid_basename qid in @@ -152,44 +164,31 @@ let interp_universe_level_name ~anon_rigidity evd qid = with UGraph.AlreadyDeclared -> evd in evd, level -let interp_universe ?loc evd = function - | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in - evd, Univ.Universe.make l - | l -> - List.fold_left (fun (evd, u) l -> - let evd', u' = - match l with - | Some (l,n) -> - (* [univ_flexible_alg] can produce algebraic universes in terms *) - let anon_rigidity = univ_flexible in - let evd', l = interp_universe_level_name ~anon_rigidity evd l in - let u' = Univ.Universe.make l in - (match n with - | 0 -> evd', u' - | 1 -> evd', Univ.Universe.super u' - | _ -> - user_err ?loc ~hdr:"interp_universe" - (Pp.(str "Cannot interpret universe increment +" ++ int n))) - | None -> - let evd, l = new_univ_level_variable ?loc univ_flexible evd in - evd, Univ.Universe.make l +let interp_universe_name ?loc evd l = + (* [univ_flexible_alg] can produce algebraic universes in terms *) + let anon_rigidity = univ_flexible in + let evd', l = interp_universe_level_name ~anon_rigidity evd l in + evd', l + +let interp_sort_name ?loc sigma = function + | GSProp -> sigma, Univ.Level.sprop + | GProp -> sigma, Univ.Level.prop + | GSet -> sigma, Univ.Level.set + | GType l -> interp_universe_name ?loc sigma l + +let interp_sort_info ?loc evd l = + List.fold_left (fun (evd, u) (l,n) -> + let evd', u' = interp_sort_name ?loc evd l in + let u' = Univ.Universe.make u' in + let u' = match n with + | 0 -> u' + | 1 -> Univ.Universe.super u' + | n -> + user_err ?loc ~hdr:"interp_universe" + (Pp.(str "Cannot interpret universe increment +" ++ int n)) in (evd', Univ.sup u u')) (evd, Univ.Universe.type0m) l -let interp_known_level_info ?loc evd = function - | UUnknown | UAnonymous -> - user_err ?loc ~hdr:"interp_known_level_info" - (str "Anonymous universes not allowed here.") - | UNamed qid -> - try interp_known_universe_level evd qid - with Not_found -> - user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_qualid qid) - -let interp_level_info ?loc evd : level_info -> _ = function - | UUnknown -> new_univ_level_variable ?loc univ_rigid evd - | UAnonymous -> new_univ_level_variable ?loc univ_flexible evd - | UNamed s -> interp_universe_level_name ~anon_rigidity:univ_flexible evd s - type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr type inference_flags = { @@ -403,13 +402,14 @@ let interp_known_glob_level ?loc evd = function | GSProp -> Univ.Level.sprop | GProp -> Univ.Level.prop | GSet -> Univ.Level.set - | GType s -> interp_known_level_info ?loc evd s + | GType qid -> + try interp_known_universe_level_name evd qid + with Not_found -> + user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_qualid qid) let interp_glob_level ?loc evd : glob_level -> _ = function - | GSProp -> evd, Univ.Level.sprop - | GProp -> evd, Univ.Level.prop - | GSet -> evd, Univ.Level.set - | GType s -> interp_level_info ?loc evd s + | UAnonymous {rigid} -> new_univ_level_variable ?loc (if rigid then univ_rigid else univ_flexible) evd + | UNamed s -> interp_sort_name ?loc evd s let interp_instance ?loc evd l = let evd, l' = @@ -448,18 +448,26 @@ let pretype_ref ?loc sigma env ref us = let ty = unsafe_type_of !!env sigma c in sigma, make_judge c ty -let judge_of_Type ?loc evd s = - let evd, s = interp_universe ?loc evd s in +let interp_sort ?loc evd : glob_sort -> _ = function + | UAnonymous {rigid} -> + let evd, l = new_univ_level_variable ?loc (if rigid then univ_rigid else univ_flexible) evd in + evd, Univ.Universe.make l + | UNamed l -> interp_sort_info ?loc evd l + +let judge_of_sort ?loc evd s = let judge = { uj_val = mkType s; uj_type = mkType (Univ.super s) } in evd, judge -let pretype_sort ?loc sigma = function - | GSProp -> sigma, judge_of_sprop - | GProp -> sigma, judge_of_prop - | GSet -> sigma, judge_of_set - | GType s -> judge_of_Type ?loc sigma s +let pretype_sort ?loc sigma s = + match s with + | UNamed [GSProp,0] -> sigma, judge_of_sprop + | UNamed [GProp,0] -> sigma, judge_of_prop + | UNamed [GSet,0] -> sigma, judge_of_set + | _ -> + let sigma, s = interp_sort ?loc sigma s in + judge_of_sort ?loc sigma s let new_type_evar env sigma loc = new_type_evar env sigma ~src:(Loc.tag ?loc Evar_kinds.InternalHole) @@ -635,24 +643,36 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let sigma, fj = pretype empty_tycon env sigma f in let floc = loc_of_glob_constr f in let length = List.length args in + let nargs_before_bidi = + (* if `f` is a global, we retrieve bidirectionality hints *) + try + let (gr,_) = destRef sigma fj.uj_val in + Option.default length @@ GlobRef.Map.find_opt gr !bidi_hints + with DestKO -> + length + in let candargs = - (* Bidirectional typechecking hint: - parameters of a constructor are completely determined - by a typing constraint *) + (* Bidirectional typechecking hint: + parameters of a constructor are completely determined + by a typing constraint *) + (* This bidirectionality machinery is the one of `Program` for + constructors and is orthogonal to bidirectionality hints. However, we + could probably factorize both by providing default bidirectionality hints + for constructors corresponding to their number of parameters. *) if program_mode && length > 0 && isConstruct sigma fj.uj_val then - match tycon with - | None -> [] - | Some ty -> + match tycon with + | None -> [] + | Some ty -> let ((ind, i), u) = destConstruct sigma fj.uj_val in let npars = inductive_nparams !!env ind in - if Int.equal npars 0 then [] - else - try - let IndType (indf, args) = find_rectype !!env sigma ty in - let ((ind',u'),pars) = dest_ind_family indf in - if eq_ind ind ind' then List.map EConstr.of_constr pars - else (* Let the usual code throw an error *) [] - with Not_found -> [] + if Int.equal npars 0 then [] + else + try + let IndType (indf, args) = find_rectype !!env sigma ty in + let ((ind',u'),pars) = dest_ind_family indf in + if eq_ind ind ind' then List.map EConstr.of_constr pars + else (* Let the usual code throw an error *) [] + with Not_found -> [] else [] in let app_f = @@ -662,20 +682,29 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let p = Projection.make p false in let npars = Projection.npars p in fun n -> - if n == npars + 1 then fun _ v -> mkProj (p, v) + if Int.equal n npars then fun _ v -> mkProj (p, v) else fun f v -> applist (f, [v]) | _ -> fun _ f v -> applist (f, [v]) in - let rec apply_rec env sigma n resj candargs = function - | [] -> sigma, resj + let rec apply_rec env sigma n resj candargs bidiargs = function + | [] -> sigma, resj, List.rev bidiargs | c::rest -> + let bidi = n >= nargs_before_bidi in let argloc = loc_of_glob_constr c in let sigma, resj = Coercion.inh_app_fun ~program_mode resolve_tc !!env sigma resj in let resty = whd_all !!env sigma resj.uj_type in match EConstr.kind sigma resty with | Prod (na,c1,c2) -> let tycon = Some c1 in - let sigma, hj = pretype tycon env sigma c in + let (sigma, hj), bidiargs = + if bidi && Option.has_some tycon then + (* We want to get some typing information from the context before + typing the argument, so we replace it by an existential + variable *) + let sigma, c_hole = new_evar env sigma ~src:(loc,Evar_kinds.InternalHole) c1 in + (sigma, make_judge c_hole c1), (c_hole, c) :: bidiargs + else pretype tycon env sigma c, bidiargs + in let sigma, candargs, ujval = match candargs with | [] -> sigma, [], j_val hj @@ -687,30 +716,45 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : sigma, args, nf_evar sigma (j_val hj) end in - let sigma, ujval = adjust_evar_source sigma na.binder_name ujval in - let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in - let j = { uj_val = value; uj_type = typ } in - apply_rec env sigma (n+1) j candargs rest - | _ -> - let sigma, hj = pretype empty_tycon env sigma c in - error_cant_apply_not_functional - ?loc:(Loc.merge_opt floc argloc) !!env sigma resj [|hj|] + let sigma, ujval = adjust_evar_source sigma na.binder_name ujval in + let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in + let j = { uj_val = value; uj_type = typ } in + apply_rec env sigma (n+1) j candargs bidiargs rest + | _ -> + let sigma, hj = pretype empty_tycon env sigma c in + error_cant_apply_not_functional + ?loc:(Loc.merge_opt floc argloc) !!env sigma resj [|hj|] in - let sigma, resj = apply_rec env sigma 1 fj candargs args in + let sigma, resj, bidiargs = apply_rec env sigma 0 fj candargs [] args in let sigma, resj = match EConstr.kind sigma resj.uj_val with | App (f,args) -> - if Termops.is_template_polymorphic_ind !!env sigma f then - (* Special case for inductive type applications that must be - refreshed right away. *) - let c = mkApp (f, args) in - let sigma, c = Evarsolve.refresh_universes (Some true) !!env sigma c in - let t = Retyping.get_type_of !!env sigma c in - sigma, make_judge c (* use this for keeping evars: resj.uj_val *) t - else sigma, resj + if Termops.is_template_polymorphic_ind !!env sigma f then + (* Special case for inductive type applications that must be + refreshed right away. *) + let c = mkApp (f, args) in + let sigma, c = Evarsolve.refresh_universes (Some true) !!env sigma c in + let t = Retyping.get_type_of !!env sigma c in + sigma, make_judge c (* use this for keeping evars: resj.uj_val *) t + else sigma, resj | _ -> sigma, resj in - inh_conv_coerce_to_tycon ?loc env sigma resj tycon + let sigma, t = inh_conv_coerce_to_tycon ?loc env sigma resj tycon in + let refine_arg sigma (newarg,origarg) = + (* Refine an argument (originally `origarg`) represented by an evar + (`newarg`) to use typing information from the context *) + (* Recover the expected type of the argument *) + let ty = Retyping.get_type_of !!env sigma newarg in + (* Type the argument using this expected type *) + let sigma, j = pretype (Some ty) env sigma origarg in + (* Unify the (possibly refined) existential variable with the + (typechecked) original value *) + Evarconv.unify_delay !!env sigma newarg (j_val j) + in + (* We now refine any arguments whose typing was delayed for + bidirectionality *) + let sigma = List.fold_left refine_arg sigma bidiargs in + (sigma, t) | GLambda(name,bk,c1,c2) -> let sigma, tycon' = diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 1037cf6cc5..d38aafd0e9 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -14,14 +14,24 @@ into elementary ones, insertion of coercions and resolution of implicit arguments. *) +open Names open Environ open Evd open EConstr open Glob_term open Ltac_pretype +val add_bidirectionality_hint : GlobRef.t -> int -> unit +(** A bidirectionality hint `n` for a global `g` tells the pretyper to use + typing information from the context after typing the `n` for arguments of an + application of `g`. *) + +val get_bidirectionality_hint : GlobRef.t -> int option + +val clear_bidirectionality_hint : GlobRef.t -> unit + val interp_known_glob_level : ?loc:Loc.t -> Evd.evar_map -> - glob_level -> Univ.Level.t + glob_sort_name -> Univ.Level.t (** An auxiliary function for searching for fixpoint guard indexes *) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 8d5213b988..27ed2189ed 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -157,10 +157,14 @@ let tag_var = tag Tag.variable let pr_sep_com sep f c = pr_with_comments ?loc:(constr_loc c) (sep() ++ f c) - let pr_univ_expr = function - | Some (x,n) -> - pr_qualid x ++ (match n with 0 -> mt () | _ -> str"+" ++ int n) - | None -> str"_" + let pr_glob_sort_name = function + | GSProp -> str "SProp" + | GProp -> str "Prop" + | GSet -> str "Set" + | GType qid -> pr_qualid qid + + let pr_univ_expr (u,n) = + pr_glob_sort_name u ++ (match n with 0 -> mt () | _ -> str"+" ++ int n) let pr_univ l = match l with @@ -170,19 +174,20 @@ let tag_var = tag Tag.variable let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" let pr_glob_sort = let open Glob_term in function - | GSProp -> tag_type (str "SProp") - | GProp -> tag_type (str "Prop") - | GSet -> tag_type (str "Set") - | GType [] -> tag_type (str "Type") - | GType u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u) + | UNamed [GSProp,0] -> tag_type (str "SProp") + | UNamed [GProp,0] -> tag_type (str "Prop") + | UNamed [GSet,0] -> tag_type (str "Set") + | UAnonymous {rigid=true} -> tag_type (str "Type") + | UAnonymous {rigid=false} -> tag_type (str "Type") ++ pr_univ_annot (fun _ -> str "_") () + | UNamed u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u) let pr_glob_level = let open Glob_term in function - | GSProp -> tag_type (str "SProp") - | GProp -> tag_type (str "Prop") - | GSet -> tag_type (str "Set") - | GType UUnknown -> tag_type (str "Type") - | GType UAnonymous -> tag_type (str "_") - | GType (UNamed u) -> tag_type (pr_qualid u) + | UNamed GSProp -> tag_type (str "SProp") + | UNamed GProp -> tag_type (str "Prop") + | UNamed GSet -> tag_type (str "Set") + | UAnonymous {rigid=true} -> tag_type (str "Type") + | UAnonymous {rigid=false} -> tag_type (str "_") + | UNamed (GType u) -> tag_type (pr_qualid u) let pr_qualid sp = let (sl, id) = repr_qualid sp in @@ -199,21 +204,8 @@ let tag_var = tag Tag.variable let pr_qualid = pr_qualid let pr_patvar = pr_id - let pr_glob_sort_instance = let open Glob_term in function - | GSProp -> - tag_type (str "SProp") - | GProp -> - tag_type (str "Prop") - | GSet -> - tag_type (str "Set") - | GType u -> - (match u with - | UNamed u -> pr_qualid u - | UAnonymous -> tag_type (str "Type") - | UUnknown -> tag_type (str "_")) - let pr_universe_instance l = - pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_glob_sort_instance)) l + pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_glob_level)) l let pr_reference qid = if qualid_is_ident qid then tag_var (pr_id @@ qualid_basename qid) diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 1332cd0168..219fe4336a 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -33,6 +33,7 @@ val pr_id : Id.t -> Pp.t val pr_qualid : qualid -> Pp.t val pr_patvar : Pattern.patvar -> Pp.t +val pr_glob_sort_name : Glob_term.glob_sort_name -> Pp.t val pr_glob_level : Glob_term.glob_level -> Pp.t val pr_glob_sort : Glob_term.glob_sort -> Pp.t val pr_guard_annot diff --git a/printing/prettyp.ml b/printing/prettyp.ml index fca33a24bf..f55bfb504f 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -304,6 +304,12 @@ let print_inductive_argument_scopes = print_args_data_of_inductive_ids Notation.find_arguments_scope (Option.has_some) print_argument_scopes +let print_bidi_hints gr = + match Pretyping.get_bidirectionality_hint gr with + | None -> [] + | Some nargs -> + [str "Using typing information from context after typing the " ++ int nargs ++ str " first arguments"] + (*********************) (* "Locate" commands *) @@ -841,7 +847,8 @@ let print_about_any ?loc env sigma k udecl = print_name_infos ref @ (if Pp.ismt rb then [] else [rb]) @ print_opacity ref @ - [hov 0 (str "Expands to: " ++ pr_located_qualid k)]) + print_bidi_hints ref @ + [hov 0 (str "Expands to: " ++ pr_located_qualid k)]) | Syntactic kn -> let () = match Syntax_def.search_syntactic_definition kn with | [],Notation_term.NRef ref -> Dumpglob.add_glob ?loc ref 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/proof_global.ml b/proofs/proof_global.ml index 40ae4acc88..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,30 +56,47 @@ 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 = t * t list 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 get_all_proof_names (pf : stack) = 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..aff48b9636 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -13,12 +13,16 @@ environment. *) type t +type stack + +val get_current_pstate : stack -> t + val get_current_proof_name : t -> Names.Id.t val get_current_persistence : t -> 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 : t -> Proof.t val compact_the_proof : t -> t @@ -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:stack option -> t -> stack + +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 conclusion); [str] describes what kind of theorem/definition this @@ -60,14 +68,14 @@ 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 (** 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 @@ -78,7 +86,8 @@ 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 -> t -> closed_proof +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> + t -> closed_proof (* Intermediate step necessary to delegate the future. * Both access the current proof state. The former is supposed to be @@ -102,9 +111,15 @@ val get_open_goals : t -> 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) -> t -> t * 'a +val modify_proof : (Proof.t -> Proof.t) -> t -> t + +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 -> t -> t @@ -120,4 +135,4 @@ val get_used_variables : t -> Constr.named_context option (** Get the universe declaration associated to the current proof. *) val get_universe_decl : t -> UState.universe_decl -val copy_terminators : src:t -> tgt:t -> t +val copy_terminators : src:stack -> tgt:stack -> stack 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 21f5ece244..5baa6ce251 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 *) @@ -1060,99 +1060,6 @@ end = struct (* {{{ *) end (* }}} *) -(* indentation code for Show Script, initially contributed - * by D. de Rauglaudre. Should be moved away. - *) - -module ShowScript = struct - -let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) = - (* ng1 : number of goals remaining at the current level (before cmd) - ngl1 : stack of previous levels with their remaining goals - ng : number of goals after the execution of cmd - beginend : special indentation stack for { } *) - let ngprev = List.fold_left (+) ng1 ngl1 in - let new_ngl = - if ng > ngprev then - (* We've branched *) - (ng - ngprev + 1, ng1 - 1 :: ngl1) - else if ng < ngprev then - (* A subgoal have been solved. Let's compute the new current level - by discarding all levels with 0 remaining goals. *) - let rec loop = function - | (0, ng2::ngl2) -> loop (ng2,ngl2) - | p -> p - in loop (ng1-1, ngl1) - else - (* Standard case, same goal number as before *) - (ng1, ngl1) - in - (* When a subgoal have been solved, separate this block by an empty line *) - let new_nl = (ng < ngprev) - in - (* Indentation depth *) - let ind = List.length ngl1 - in - (* Some special handling of bullets and { }, to get a nicer display *) - let pred n = max 0 (n-1) in - let ind, nl, new_beginend = match Vernacprop.under_control cmd with - | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend - | VernacEndSubproof -> List.hd beginend, false, List.tl beginend - | VernacBullet _ -> pred ind, nl, beginend - | _ -> ind, nl, beginend - in - let pp = Pp.( - (if nl then fnl () else mt ()) ++ - (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd))) - in - (new_ngl, new_nl, new_beginend, pp :: ppl) - -let get_script prf = - let branch, test = - match prf with - | None -> VCS.Branch.master, fun _ -> true - | Some name -> VCS.current_branch (),fun nl -> nl=[] || List.mem name nl in - let rec find acc id = - if Stateid.equal id Stateid.initial || - Stateid.equal id Stateid.dummy then acc else - let view = VCS.visit id in - match view.step with - | `Fork((_,_,_,ns), _) when test ns -> acc - | `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof - | `Sideff (ReplayCommand x,_) -> - find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next - | `Sideff (CherryPickEnv, id) -> find acc id - | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *) - find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next - | `Cmd _ -> find acc view.next - | `Alias (id,_) -> find acc id - | `Fork _ -> find acc view.next - in - find [] (VCS.get_branch_pos branch) - -let warn_show_script_deprecated = - CWarnings.create ~name:"deprecated-show-script" ~category:"deprecated" - (fun () -> Pp.str "The “Show Script” command is deprecated.") - -let show_script ?proof () = - warn_show_script_deprecated (); - try - let prf = - try match proof with - | None -> Some (PG_compat.get_current_proof_name ()) - | Some (p,_) -> Some (p.Proof_global.id) - with PG_compat.NoCurrentProof -> None - in - let cmds = get_script prf in - let _,_,_,indented_cmds = - List.fold_left indent_script_item ((1,[]),false,[],[]) cmds - in - let indented_cmds = List.rev (indented_cmds) in - msg_notice Pp.(v 0 (prlist_with_sep fnl (fun x -> x) indented_cmds)) - with Vcs_aux.Expired -> () - -end - (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly reduced... *) @@ -1172,21 +1079,17 @@ let stm_vernac_interp ?proof ?route id st { verbose; expr } : Vernacstate.t = | VernacAbortAll | VernacAbort _ -> true | _ -> false in - let aux_interp st expr = - (* XXX unsupported attributes *) - let cmd = Vernacprop.under_control expr in - if is_filtered_command cmd then - (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) - else - match cmd with - | VernacShow ShowScript -> ShowScript.show_script (); st (* XX we are ignoring control here *) - | _ -> - stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st expr - with e -> - let e = CErrors.push e in - Exninfo.iraise Hooks.(call_process_error_once e) - in aux_interp st expr + (* XXX unsupported attributes *) + let cmd = Vernacprop.under_control expr in + if is_filtered_command cmd then + (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) + else begin + stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); + try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st expr + with e -> + let e = CErrors.push e in + Exninfo.iraise Hooks.(call_process_error_once e) + end (****************************** CRUFT *****************************************) (******************************************************************************) @@ -1265,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 = @@ -1734,7 +1639,7 @@ and Slaves : sig val info_tasks : 'a tasks -> (string * float * int) list val finish_task : string -> - Library.seg_univ -> Library.seg_discharge -> Library.seg_proofs -> + Library.seg_univ -> Library.seg_proofs -> int tasks -> int -> Library.seg_univ val cancel_worker : WorkerPool.worker_id -> unit @@ -1819,7 +1724,7 @@ end = struct (* {{{ *) str (Printexc.to_string e))); if drop then `ERROR_ADMITTED else `ERROR - let finish_task name (cst,_) d p l i = + let finish_task name (cst,_) p l i = let { Stateid.uuid = bucket }, drop = List.nth l i in let bucket_name = if bucket < 0 then (assert drop; ", no bucket") @@ -1829,7 +1734,6 @@ end = struct (* {{{ *) | `ERROR_ADMITTED -> cst, false | `OK_ADMITTED -> cst, false | `OK (po,_) -> - let discharge c = List.fold_right Cooking.cook_constr d.(bucket) c in let con = Nametab.locate_constant (Libnames.qualid_of_ident po.Proof_global.id) in @@ -1841,12 +1745,14 @@ end = struct (* {{{ *) the call to [check_task_aux] above. *) let uc = Opaqueproof.force_constraints Library.indirect_accessor (Global.opaque_tables ()) o in let uc = Univ.hcons_universe_context_set uc in + let (pr, ctx) = Option.get (Global.body_of_constant_body Library.indirect_accessor c) in (* We only manipulate monomorphic terms here. *) - let map (c, ctx) = assert (Univ.AUContext.is_empty ctx); c in - let pr = map (Option.get (Global.body_of_constant_body Library.indirect_accessor c)) in - let pr = discharge pr in + let () = assert (Univ.AUContext.is_empty ctx) in let pr = Constr.hcons pr in - p.(bucket) <- Some pr; + let (ci, univs, dummy) = p.(bucket) in + let () = assert (Option.is_empty dummy) in + let () = assert (Int.equal (Univ.AUContext.size ctx) univs) in + p.(bucket) <- ci, univs, Some pr; Univ.ContextSet.union cst uc, false let check_task name l i = @@ -2842,11 +2748,11 @@ let check_task name (tasks,rcbackup) i = with e when CErrors.noncritical e -> VCS.restore vcs; false let info_tasks (tasks,_) = Slaves.info_tasks tasks -let finish_tasks name u d p (t,rcbackup as tasks) = +let finish_tasks name u p (t,rcbackup as tasks) = RemoteCounter.restore rcbackup; let finish_task u (_,_,i) = let vcs = VCS.backup () in - let u = State.purify (Slaves.finish_task name u d p t) i in + let u = State.purify (Slaves.finish_task name u p t) i in VCS.restore vcs; u in try diff --git a/stm/stm.mli b/stm/stm.mli index 5e1e9bf5ad..86e2566539 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -167,7 +167,7 @@ type tasks val check_task : string -> tasks -> int -> bool val info_tasks : tasks -> (string * float * int) list val finish_tasks : string -> - Library.seg_univ -> Library.seg_discharge -> Library.seg_proofs -> + Library.seg_univ -> Library.seg_proofs -> tasks -> Library.seg_univ * Library.seg_proofs (* Id of the tip of the current branch *) diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index 0f78e0acf6..cf0c8934b0 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -12,7 +12,7 @@ open Util let check_vio (ts,f_in) = Dumpglob.noglob (); - let _, _, _, _, tasks, _ = Library.load_library_todo f_in in + let _, _, _, tasks, _ = Library.load_library_todo f_in in Stm.set_compilation_hints f_in; List.fold_left (fun acc ids -> Stm.check_task f_in tasks ids && acc) true ts @@ -29,7 +29,7 @@ let schedule_vio_checking j fs = if j < 1 then CErrors.user_err Pp.(str "The number of workers must be bigger than 0"); let jobs = ref [] in List.iter (fun long_f_dot_vio -> - let _,_,_,_, tasks, _ = Library.load_library_todo long_f_dot_vio in + let _,_,_, tasks, _ = Library.load_library_todo long_f_dot_vio in Stm.set_compilation_hints long_f_dot_vio; let infos = Stm.info_tasks tasks in let eta = List.fold_left (fun a (_,t,_) -> a +. t) 0.0 infos in diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 1170c1acd0..8ead050262 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -59,7 +59,7 @@ let build_induction_scheme_in_type dep sort ind = let sigma, pind = Evd.fresh_inductive_instance env sigma ind in let sigma, c = build_induction_scheme env sigma pind dep sort in c, Evd.evar_universe_context sigma - + let rect_scheme_kind_from_type = declare_individual_scheme_object "_rect_nodep" (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) @@ -108,6 +108,16 @@ let sind_scheme_kind_from_prop = declare_individual_scheme_object "_sind" ~aux:"_sind_from_prop" (fun _ x -> build_induction_scheme_in_type false InSProp x, Safe_typing.empty_private_constants) +let nondep_elim_scheme from_kind to_kind = + match from_kind, to_kind with + | InProp, InProp -> ind_scheme_kind_from_prop + | InProp, InSProp -> sind_scheme_kind_from_prop + | InProp, InSet -> rec_scheme_kind_from_prop + | InProp, InType -> rect_scheme_kind_from_prop + | _ , InProp -> ind_scheme_kind_from_type + | _ , InSProp -> sind_scheme_kind_from_type + | _ , InSet -> rec_scheme_kind_from_type + | _ , InType -> rect_scheme_kind_from_type (* Case analysis *) diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index 4472792449..f60e6c137a 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -33,6 +33,7 @@ val sind_dep_scheme_kind_from_type : individual scheme_kind val rec_scheme_kind_from_type : individual scheme_kind val rec_dep_scheme_kind_from_type : individual scheme_kind +val nondep_elim_scheme : Sorts.family -> Sorts.family -> individual scheme_kind (** Case analysis schemes *) diff --git a/tactics/equality.ml b/tactics/equality.ml index 51eee2a053..ec0876110b 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -352,35 +352,35 @@ let find_elim hdcncl lft2rgt dep cls ot = (is_global_exists "core.JMeq.type" hdcncl && jmeq_same_dom env sigma ot)) && not dep then - let c = + let c = match EConstr.kind sigma hdcncl with - | Ind (ind_sp,u) -> - let pr1 = + | Ind (ind_sp,u) -> + let pr1 = lookup_eliminator env ind_sp (elimination_sort_of_clause cls gl) - in + in begin match lft2rgt, cls with | Some true, None | Some false, Some _ -> - let c1 = destConstRef pr1 in + let c1 = destConstRef pr1 in let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical c1)) in - let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in + let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (KerName.make mp l') in - begin - try - let _ = Global.lookup_constant c1' in - c1' - with Not_found -> + begin + try + let _ = Global.lookup_constant c1' in + c1' + with Not_found -> user_err ~hdr:"Equality.find_elim" (str "Cannot find rewrite principle " ++ Label.print l' ++ str ".") end - | _ -> destConstRef pr1 + | _ -> destConstRef pr1 end | _ -> (* cannot occur since we checked that we are in presence of Logic.eq or Jmeq just before *) assert false in - pf_constr_of_global (ConstRef c) + pf_constr_of_global (ConstRef c) else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) @@ -946,12 +946,12 @@ let build_coq_I () = pf_constr_of_global (lib_ref "core.True.I") let rec build_discriminator env sigma true_0 false_0 dirn c = function | [] -> let ind = get_type_of env sigma c in - build_selector env sigma dirn c ind true_0 false_0 + build_selector env sigma dirn c ind true_0 (fst false_0) | ((sp,cnum),argnum)::l -> let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in let subval = build_discriminator cnum_env sigma true_0 false_0 dirn newc l in - kont sigma subval (false_0,mkProp) + kont sigma subval false_0 (* Note: discrimination could be more clever: if some elimination is not allowed because of a large impredicative constructor in the @@ -983,25 +983,22 @@ let gen_absurdity id = absurd_term=False *) -let ind_scheme_of_eq lbeq = +let ind_scheme_of_eq lbeq to_kind = let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in - let kind = inductive_sort_family mip in + let from_kind = inductive_sort_family mip in (* use ind rather than case by compatibility *) - let kind = - if kind == InProp then Elimschemes.ind_scheme_kind_from_prop - else Elimschemes.ind_scheme_kind_from_type in + let kind = Elimschemes.nondep_elim_scheme from_kind to_kind in let c, eff = find_scheme kind (destIndRef lbeq.eq) in ConstRef c, eff -let discrimination_pf e (t,t1,t2) discriminator lbeq = +let discrimination_pf e (t,t1,t2) discriminator lbeq to_kind = build_coq_I () >>= fun i -> - build_coq_False () >>= fun absurd_term -> - let eq_elim, eff = ind_scheme_of_eq lbeq in + let eq_elim, eff = ind_scheme_of_eq lbeq to_kind in Proofview.tclEFFECTS eff <*> pf_constr_of_global eq_elim >>= fun eq_elim -> Proofview.tclUNIT - (applist (eq_elim, [t;t1;mkNamedLambda (make_annot e Sorts.Relevant) t discriminator;i;t2]), absurd_term) + (applist (eq_elim, [t;t1;mkNamedLambda (make_annot e Sorts.Relevant) t discriminator;i;t2])) let eq_baseid = Id.of_string "e" @@ -1018,21 +1015,23 @@ let apply_on_clause (f,t) clause = let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = build_coq_True () >>= fun true_0 -> build_coq_False () >>= fun false_0 -> + let false_ty = Retyping.get_type_of env sigma false_0 in + let false_kind = Retyping.get_sort_family_of env sigma false_0 in let e = next_ident_away eq_baseid (vars_of_env env) in let e_env = push_named (Context.Named.Declaration.LocalAssum (make_annot e Sorts.Relevant,t)) env in let discriminator = try Proofview.tclUNIT - (build_discriminator e_env sigma true_0 false_0 dirn (mkVar e) cpath) + (build_discriminator e_env sigma true_0 (false_0,false_ty) dirn (mkVar e) cpath) with UserError _ as ex -> Proofview.tclZERO ex in discriminator >>= fun discriminator -> - discrimination_pf e (t,t1,t2) discriminator lbeq >>= fun (pf, absurd_term) -> - let pf_ty = mkArrow eqn Sorts.Relevant absurd_term in + discrimination_pf e (t,t1,t2) discriminator lbeq false_kind >>= fun pf -> + let pf_ty = mkArrow eqn Sorts.Relevant false_0 in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in - tclTHENS (assert_after Anonymous absurd_term) + tclTHENS (assert_after Anonymous false_0) [onLastHypId gen_absurdity; (Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr pf)))] let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = diff --git a/test-suite/Makefile b/test-suite/Makefile index 94011447d7..552d007f85 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -561,7 +561,6 @@ $(patsubst %.sh,%.log,$(wildcard misc/*.sh)): %.log: %.sh $(PREREQUISITELOG) export coqc="$(coqc)"; \ export coqtop="$(coqc)"; \ export coqdep="$(coqdep)"; \ - export coqtopbyte="$(coqtopbyte)"; \ "$<" 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ diff --git a/test-suite/bugs/closed/bug_10264.v b/test-suite/bugs/closed/bug_10264.v new file mode 100644 index 0000000000..8351f8325b --- /dev/null +++ b/test-suite/bugs/closed/bug_10264.v @@ -0,0 +1,10 @@ +Require Import Program.Tactics. + +Definition bla (A:Type) := A. +Existing Class bla. + +Program Instance fubar : bla nat := {}. +Next Obligation. +Fail exact bool. +exact 0. +Qed. 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. diff --git a/test-suite/bugs/closed/bug_4869.v b/test-suite/bugs/closed/bug_4869.v index ac5d7ea287..1fe91de72d 100644 --- a/test-suite/bugs/closed/bug_4869.v +++ b/test-suite/bugs/closed/bug_4869.v @@ -6,7 +6,9 @@ Fail Constraint i = Set. Constraint Set <= i. Constraint Set < i. Fail Constraint i < j. (* undeclared j *) +(* Now a parsing error Fail Constraint i < Type. (* anonymous *) +*) Set Universe Polymorphism. diff --git a/test-suite/ltac2/notations.v b/test-suite/ltac2/notations.v new file mode 100644 index 0000000000..3d2a875e38 --- /dev/null +++ b/test-suite/ltac2/notations.v @@ -0,0 +1,24 @@ +From Ltac2 Require Import Ltac2. +From Coq Require Import ZArith String List. + +Open Scope Z_scope. + +Check 1 + 1 : Z. + +Ltac2 Notation "ex" arg(constr(nat,Z)) := arg. + +Check (1 + 1)%nat%Z = 1%nat. + +Lemma two : nat. + refine (ex (1 + 1)). +Qed. + +Import ListNotations. +Close Scope list_scope. + +Ltac2 Notation "sl" arg(constr(string,list)) := arg. + +Lemma maybe : list bool. +Proof. + refine (sl ["left" =? "right"]). +Qed. diff --git a/test-suite/misc/printers.sh b/test-suite/misc/printers.sh index ef3f056d89..f659fce680 100755 --- a/test-suite/misc/printers.sh +++ b/test-suite/misc/printers.sh @@ -1,2 +1,8 @@ #!/bin/sh -if printf "Drop. #use\"include\";; #quit;;\n" | $coqtopbyte 2>&1 | grep -E "Error|Unbound" ; then exit 1; else exit 0; fi + +command -v "${BIN}coqtop.byte" || { echo "Missing coqtop.byte"; exit 1; } + +f=$(mktemp) +printf 'Drop. #use"include";; #quit;;\n' | "${BIN}coqtop.byte" -q 2>&1 | tee "$f" + +if grep -q -E "Error|Unbound" "$f"; then exit 1; fi diff --git a/test-suite/ssr/case_polyuniv.v b/test-suite/ssr/case_polyuniv.v new file mode 100644 index 0000000000..8774e191c1 --- /dev/null +++ b/test-suite/ssr/case_polyuniv.v @@ -0,0 +1,12 @@ +Require Import ssreflect. + +Set Universe Polymorphism. + +Cumulative Variant paths {A} (x:A) : A -> Type + := idpath : paths x x. + +Register paths as core.eq.type. +Register idpath as core.eq.refl. + +Lemma case_test (b:bool) : paths b b. +Proof. case B:b; reflexivity. Qed. diff --git a/test-suite/ssr/unfold_fold_polyuniv.v b/test-suite/ssr/unfold_fold_polyuniv.v new file mode 100644 index 0000000000..1a9309bc79 --- /dev/null +++ b/test-suite/ssr/unfold_fold_polyuniv.v @@ -0,0 +1,40 @@ +Require Import ssreflect ssrbool. + +Set Universe Polymorphism. + +Cumulative Variant paths {A} (x:A) : A -> Type + := idpath : paths x x. + +Register paths as core.eq.type. +Register idpath as core.eq.refl. + +Structure type := Pack {sort; op : rel sort}. + +Example unfold_fold (T : type) (x : sort T) (a : op T x x) : op T x x. +Proof. + rewrite /op. rewrite -/(op _ _ _). assumption. +Qed. + +Example pattern_unfold_fold (b:bool) (a := b) : paths a b. +Proof. + rewrite [in X in paths X _]/a. + rewrite -[in X in paths X _]/a. + constructor. +Qed. + +Example unfold_in_hyp (b:bool) (a := b) : unit. +Proof. + assert (paths a a) as A by reflexivity. + rewrite [in X in paths X _]/a in A. + rewrite /a in (B := idpath a). + rewrite [in X in paths _ X]/a in (C := idpath a). + constructor. +Qed. + +Example fold_in_hyp (b:bool) (p := idpath b) : unit. +Proof. + assert (paths (idpath b) (idpath b)) as A by reflexivity. + rewrite -[in X in paths X _]/p in A. + rewrite -[in X in paths _ X]/p in (C := idpath (idpath b)). + constructor. +Qed. diff --git a/test-suite/success/BidirectionalityHints.v b/test-suite/success/BidirectionalityHints.v new file mode 100644 index 0000000000..284cdc871b --- /dev/null +++ b/test-suite/success/BidirectionalityHints.v @@ -0,0 +1,114 @@ +From Coq Require Import Utf8. +Set Default Proof Using "Type". + +Module SimpleExamples. + +Axiom c : bool -> nat. +Coercion c : bool >-> nat. +Inductive Boxed A := Box (a : A). +Arguments Box {A} & a. +Check Box true : Boxed nat. + +(* Here we check that there is no regression due e.g. to refining arguments + in the wrong order *) +Axiom f : forall b : bool, (if b then bool else nat) -> Type. +Check f true true : Type. +Arguments f & _ _. +Check f true true : Type. + +End SimpleExamples. + +Module Issue7910. + +Local Set Universe Polymorphism. + +(** Telescopes *) +Inductive tele : Type := + | TeleO : tele + | TeleS {X} (binder : X → tele) : tele. + +Arguments TeleS {_} _. + +(** The telescope version of Coq's function type *) +Fixpoint tele_fun (TT : tele) (T : Type) : Type := + match TT with + | TeleO => T + | TeleS b => ∀ x, tele_fun (b x) T + end. + +Notation "TT -t> A" := + (tele_fun TT A) (at level 99, A at level 200, right associativity). + +(** An eliminator for elements of [tele_fun]. + We use a [fix] because, for some reason, that makes stuff print nicer + in the proofs in iris:bi/lib/telescopes.v *) +Definition tele_fold {X Y} {TT : tele} (step : ∀ {A : Type}, (A → Y) → Y) (base : X → Y) + : (TT -t> X) → Y := + (fix rec {TT} : (TT -t> X) → Y := + match TT as TT return (TT -t> X) → Y with + | TeleO => λ x : X, base x + | TeleS b => λ f, step (λ x, rec (f x)) + end) TT. +Arguments tele_fold {_ _ !_} _ _ _ /. + +(** A sigma-like type for an "element" of a telescope, i.e. the data it + takes to get a [T] from a [TT -t> T]. *) +Inductive tele_arg : tele → Type := +| TargO : tele_arg TeleO +(* the [x] is the only relevant data here *) +| TargS {X} {binder} (x : X) : tele_arg (binder x) → tele_arg (TeleS binder). + +Definition tele_app {TT : tele} {T} (f : TT -t> T) : tele_arg TT → T := + λ a, (fix rec {TT} (a : tele_arg TT) : (TT -t> T) → T := + match a in tele_arg TT return (TT -t> T) → T with + | TargO => λ t : T, t + | TargS x a => λ f, rec a (f x) + end) TT a f. +Arguments tele_app {!_ _} & _ !_ /. + +Coercion tele_arg : tele >-> Sortclass. +Coercion tele_app : tele_fun >-> Funclass. + +(** Operate below [tele_fun]s with argument telescope [TT]. *) +Fixpoint tele_bind {U} {TT : tele} : (TT → U) → TT -t> U := + match TT as TT return (TT → U) → TT -t> U with + | TeleO => λ F, F TargO + | @TeleS X b => λ (F : TeleS b → U) (x : X), (* b x -t> U *) + tele_bind (λ a, F (TargS x a)) + end. +Arguments tele_bind {_ !_} _ /. + +(** Telescopic quantifiers *) +Definition tforall {TT : tele} (Ψ : TT → Prop) : Prop := + tele_fold (λ (T : Type) (b : T → Prop), ∀ x : T, b x) (λ x, x) (tele_bind Ψ). +Arguments tforall {!_} _ /. +Definition texist {TT : tele} (Ψ : TT → Prop) : Prop := + tele_fold ex (λ x, x) (tele_bind Ψ). +Arguments texist {!_} _ /. + +Notation "'∀..' x .. y , P" := (tforall (λ x, .. (tforall (λ y, P)) .. )) + (at level 200, x binder, y binder, right associativity, + format "∀.. x .. y , P"). +Notation "'∃..' x .. y , P" := (texist (λ x, .. (texist (λ y, P)) .. )) + (at level 200, x binder, y binder, right associativity, + format "∃.. x .. y , P"). + +(** The actual test case *) +Definition test {TT : tele} (t : TT → Prop) : Prop := + ∀.. x, t x ∧ t x. + +Notation "'[TEST' x .. z , P ']'" := + (test (TT:=(TeleS (fun x => .. (TeleS (fun z => TeleO)) ..))) + (tele_app (λ x, .. (λ z, P) ..))) + (x binder, z binder). +Notation "'[TEST2' x .. z , P ']'" := + (test (TT:=(TeleS (fun x => .. (TeleS (fun z => TeleO)) ..))) + (tele_app (TT:=(TeleS (fun x => .. (TeleS (fun z => TeleO)) ..))) + (λ x, .. (λ z, P) ..))) + (x binder, z binder). + +Check [TEST (x y : nat), x = y]. + +Check [TEST2 (x y : nat), x = y]. + +End Issue7910. diff --git a/test-suite/success/Discriminate_HoTT.v b/test-suite/success/Discriminate_HoTT.v new file mode 100644 index 0000000000..2a5e083d56 --- /dev/null +++ b/test-suite/success/Discriminate_HoTT.v @@ -0,0 +1,89 @@ +(* -*- mode: coq; coq-prog-args: ("-noinit" "-indices-matter") -*- *) + +(* This file tests the discriminate tactic compatibility with HoTT. + The first part of the file will setup a mini HoTT environment. + Afterwards a number of tests are performed. The tests are basically + copied from the Discriminate.v test file. *) + +Unset Elimination Schemes. + +Set Universe Polymorphism. + +Declare ML Module "ltac_plugin". + +Global Set Default Proof Mode "Classic". + +Notation "x -> y" := (forall (_:x), y) (at level 99, right associativity, y at level 200). + +Cumulative Variant paths {A} (a:A) : A -> Type + := idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Scheme paths_ind := Induction for paths Sort Type. +Arguments paths_ind [A] a P f y p. + +Notation "x = y :> A" := (@paths A x y) (at level 70, y at next level, no associativity). +Notation "x = y" := (x = y :>_) (at level 70, no associativity). + +Register paths as core.identity.type. +Register idpath as core.identity.refl. +Register paths_ind as core.identity.ind. + +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. +Arguments inverse {A x y} p : simpl nomatch. +Register inverse as core.identity.sym. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. +Arguments concat {A x y z} p q : simpl nomatch. +Register concat as core.identity.trans. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. +Arguments ap {A B} f {x y} p. +Register ap as core.identity.congr. + +Variant Empty : Type :=. + +Register Empty as core.False.type. + +Variant Unit : Type := tt. + +Register Unit as core.True.type. +Register tt as core.True.I. + +Variant Bool : Type := true | false. + +Inductive nat : Type := O | S (n:nat). + +(*********** Test discriminate tactic below. ***************) + +Goal O = S O -> Empty. + discriminate 1. +Qed. + +Goal forall H : O = S O, H = H. + discriminate H. +Qed. + +Goal O = S O -> Unit. +intros. discriminate H. Qed. +Goal O = S O -> Unit. +intros. Ltac g x := discriminate x. g H. Qed. + +Goal (forall x y : nat, x = y -> x = S y) -> Unit. +intros. +try discriminate (H O) || exact tt. +Qed. + +Goal (forall x y : nat, x = y -> x = S y) -> Unit. +intros. ediscriminate (H O). instantiate (1:=O). Abort. + +(* Check discriminate on types with local definitions *) + +Inductive A := B (T := Unit) (x y : Bool) (z := x). +Goal forall x y, B x true = B y false -> Empty. +discriminate. +Qed. diff --git a/test-suite/vio/section.v b/test-suite/vio/section.v new file mode 100644 index 0000000000..0e7722516a --- /dev/null +++ b/test-suite/vio/section.v @@ -0,0 +1,12 @@ +Section Foo. + Variable A : Type. + + Definition bla := A. + + Variable B : bla. + + Lemma blu : {X:Type & X}. + Proof using A B. + exists bla;exact B. + Qed. +End Foo. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 6ddc503542..b5d1e01630 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -128,6 +128,7 @@ module Options = struct [ { enabled = false; cmd = "-debug"; } ; { enabled = false; cmd = "-native_compiler"; } ; { enabled = true; cmd = "-allow-sprop"; } + ; { enabled = true; cmd = "-w +default"; } ] let build_coq_flags () = diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 7748134146..2e25066897 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -176,9 +176,9 @@ let compile opts copts ~echo ~f_in ~f_out = Dumpglob.noglob (); let long_f_dot_vio, long_f_dot_vo = ensure_exists_with_prefix f_in f_out ".vio" ".vo" in - let sum, lib, univs, disch, tasks, proofs = + let sum, lib, univs, tasks, proofs = Library.load_library_todo long_f_dot_vio in - let univs, proofs = Stm.finish_tasks long_f_dot_vo univs disch proofs tasks in + let univs, proofs = Stm.finish_tasks long_f_dot_vo univs proofs tasks in Library.save_library_raw long_f_dot_vo sum lib univs proofs let compile opts copts ~echo ~f_in ~f_out = diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 890ed76d52..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 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/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index da8600109e..e2bab96e20 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1355,6 +1355,16 @@ let () = add_scope "thunk" begin function | arg -> scope_fail "thunk" arg end +let () = add_scope "constr" (fun arg -> + let delimiters = List.map (function + | SexprRec (_, { v = Some s }, []) -> s + | _ -> scope_fail "constr" arg) + arg + in + let act e = Tac2quote.of_constr ~delimiters e in + Tac2entries.ScopeRule (Extend.Aentry Pcoq.Constr.constr, act) + ) + let add_expr_scope name entry f = add_scope name begin function | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) @@ -1382,7 +1392,6 @@ let () = add_expr_scope "assert" q_assert Tac2quote.of_assertion let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching -let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern 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 d493192bb3..80d48f67ba 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.t option -> strexpr -> unit val register_notation : ?local:bool -> sexpr list -> int option -> raw_tacexpr -> unit +val perform_eval : pstate:Proof_global.t option -> raw_tacexpr -> unit + (** {5 Notations} *) type scope_rule = 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/user-contrib/Ltac2/tac2quote.ml b/user-contrib/Ltac2/tac2quote.ml index a98264745e..81442c9d6b 100644 --- a/user-contrib/Ltac2/tac2quote.ml +++ b/user-contrib/Ltac2/tac2quote.ml @@ -94,8 +94,14 @@ let of_anti f = function let of_ident {loc;v=id} = inj_wit ?loc wit_ident id -let of_constr c = +let of_constr ?delimiters c = let loc = Constrexpr_ops.constr_loc c in + let c = Option.cata + (List.fold_left (fun c d -> + CAst.make ?loc @@ Constrexpr.CDelimiters(Id.to_string d, c)) + c) + c delimiters + in inj_wit ?loc wit_constr c let of_open_constr c = diff --git a/user-contrib/Ltac2/tac2quote.mli b/user-contrib/Ltac2/tac2quote.mli index 1b03dad8ec..1c859063aa 100644 --- a/user-contrib/Ltac2/tac2quote.mli +++ b/user-contrib/Ltac2/tac2quote.mli @@ -32,7 +32,7 @@ val of_variable : Id.t CAst.t -> raw_tacexpr val of_ident : Id.t CAst.t -> raw_tacexpr -val of_constr : Constrexpr.constr_expr -> raw_tacexpr +val of_constr : ?delimiters:Id.t list -> Constrexpr.constr_expr -> raw_tacexpr val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr diff --git a/vernac/classes.ml b/vernac/classes.ml index ea66234993..9cc8467c57 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,9 +331,9 @@ 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 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) @@ -344,136 +344,78 @@ 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 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 - 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 = - 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 +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 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 + 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 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) + 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 + 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 (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 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_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. *) @@ -484,17 +426,110 @@ let do_instance ~pstate env env' sigma ?hook ~tac ~global ~poly ~program_mode 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 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 - else CErrors.user_err Pp.(str "Unsolved obligations remaining.") in - id, pstate - -let interp_instance_context ~program_mode env ctx ?(generalize=false) pl tclass = + 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 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 = + 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 ~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: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: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 + 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 ~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: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: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:true 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 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) @@ -522,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 ~pstate ?(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 @@ -538,13 +571,41 @@ 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 - cty k u ctx ctx' pri decl imps subst id props + id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl + +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:false ~generalize env instid ctx cl in + 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) ?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 ~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) ?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 ~global ~poly + 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 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 8d5f3e3a06..e61935c87a 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -31,34 +31,41 @@ 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_interactive : + ?global:bool (** Not global by default. *) + -> 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 : - pstate:Proof_global.t option - -> ?global:bool (** Not global by default. *) - -> program_mode:bool + ?global:bool (** Not global by default. *) + -> Decl_kinds.polymorphic + -> name_decl + -> local_binder_expr list + -> constr_expr + -> (bool * constr_expr) + -> ?generalize:bool + -> ?hook:(GlobRef.t -> unit) + -> Hints.hint_info_expr + -> Id.t + +val new_instance_program : + ?global:bool (** Not global by default. *) -> Decl_kinds.polymorphic -> name_decl -> local_binder_expr list -> constr_expr -> (bool * constr_expr) option -> ?generalize:bool - -> ?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 a428c42e49..7a4e6d8698 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -255,80 +255,79 @@ 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 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 ~ontop (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; +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_cofixpoint ~ontop 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 ~ontop (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; +let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes 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 = + (* 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 | (CWfRec (na,_) | CMeasureRec (Some na,_,_)) when not structonly -> 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 ~ontop 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 ~ontop 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 ~ontop 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 ~ontop 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 5937842f17..c8d617da5f 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -18,15 +18,17 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) +val do_fixpoint_interactive : + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t + 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 -> unit + +val do_cofixpoint_interactive : + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t 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 -> unit (************************************************************************) (** Internal API *) @@ -83,20 +85,16 @@ 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.lemma_possible_guards -> decl_notation list -> unit 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 + decl_notation list -> unit (** Very private function, do not use *) val compute_possible_guardness_evidences : diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 977e804da2..5bebf955ec 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -121,7 +121,7 @@ let mk_mltype_data sigma env assums arity indname = let rec check_anonymous_type ind = let open Glob_term in match DAst.get ind with - | GSort (GType []) -> true + | GSort (UAnonymous {rigid=true}) -> true | GProd ( _, _, _, e) | GLetIn (_, _, _, e) | GLambda (_, _, _, e) @@ -495,7 +495,7 @@ let extract_params indl = let extract_inductive indl = List.map (fun ({CAst.v=indname},_,ar,lc) -> { ind_name = indname; - ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (Glob_term.GType [])) ar; + ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (Glob_term.UAnonymous {rigid=true})) ar; ind_lc = List.map (fun (_,({CAst.v=id},t)) -> (id,t)) lc }) indl diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index ecc7d3ff88..ea35ea782d 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -88,7 +88,6 @@ GRAMMAR EXTEND Gram | IDENT "Show" -> { VernacShow (ShowGoal OpenSubgoals) } | IDENT "Show"; n = natural -> { VernacShow (ShowGoal (NthGoal n)) } | IDENT "Show"; id = ident -> { VernacShow (ShowGoal (GoalId id)) } - | IDENT "Show"; IDENT "Script" -> { VernacShow ShowScript } | IDENT "Show"; IDENT "Existentials" -> { VernacShow ShowExistentials } | IDENT "Show"; IDENT "Universes" -> { VernacShow ShowUniverses } | IDENT "Show"; IDENT "Conjectures" -> { VernacShow ShowProofNames } diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 7c8c2b10ab..cec68b89bc 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 = @@ -296,8 +295,8 @@ GRAMMAR EXTEND Gram | -> { NoInline } ] ] ; univ_constraint: - [ [ l = universe_level; ord = [ "<" -> { Univ.Lt } | "=" -> { Univ.Eq } | "<=" -> { Univ.Le } ]; - r = universe_level -> { (l, ord, r) } ] ] + [ [ l = universe_name; ord = [ "<" -> { Univ.Lt } | "=" -> { Univ.Eq } | "<=" -> { Univ.Le } ]; + r = universe_name -> { (l, ord, r) } ] ] ; univ_decl : [ [ "@{" ; l = LIST0 identref; ext = [ "+" -> { true } | -> { false } ]; @@ -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 *) @@ -752,6 +751,7 @@ GRAMMAR EXTEND Gram mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> { l } ] -> { let mods = match mods with None -> [] | Some l -> List.flatten l in let slash_position = ref None in + let ampersand_position = ref None in let rec parse_args i = function | [] -> [] | `Id x :: args -> x :: parse_args (i+1) args @@ -760,10 +760,15 @@ GRAMMAR EXTEND Gram (slash_position := Some i; parse_args i args) else user_err Pp.(str "The \"/\" modifier can occur only once") + | `Ampersand :: args -> + if Option.is_empty !ampersand_position then + (ampersand_position := Some i; parse_args i args) + else + user_err Pp.(str "The \"&\" modifier can occur only once") in let args = parse_args 0 (List.flatten args) in let more_implicits = Option.default [] more_implicits in - VernacArguments (qid, args, more_implicits, !slash_position, mods) } + VernacArguments (qid, args, more_implicits, !slash_position, !ampersand_position, mods) } | IDENT "Implicit"; "Type"; bl = reserv_list -> { VernacReserve bl } @@ -785,6 +790,7 @@ GRAMMAR EXTEND Gram | IDENT "default"; IDENT "implicits" -> { [`DefaultImplicits] } | IDENT "clear"; IDENT "implicits" -> { [`ClearImplicits] } | IDENT "clear"; IDENT "scopes" -> { [`ClearScopes] } + | IDENT "clear"; IDENT "bidirectionality"; IDENT "hint" -> { [`ClearBidiHint] } | IDENT "rename" -> { [`Rename] } | IDENT "assert" -> { [`Assert] } | IDENT "extra"; IDENT "scopes" -> { [`ExtraScopes] } @@ -810,6 +816,7 @@ GRAMMAR EXTEND Gram notation_scope=notation_scope; implicit_status = NotImplicit}] } | "/" -> { [`Slash] } + | "&" -> { [`Ampersand] } | "("; items = LIST1 argument_spec; ")"; sc = OPT scope -> { let f x = match sc, x with | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc y) x diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 740b9031cc..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 *) @@ -329,7 +325,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 +336,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 +352,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 +384,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 +423,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 +483,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..3df543156d 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -37,7 +37,7 @@ 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 -> @@ -45,12 +45,11 @@ val start_proof : ontop:Proof_global.t option -> Id.t -> ?pl:UState.universe_dec 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 -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 -> @@ -62,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 : unit -> Id.t (* Prepare global named context for proof session: remove proofs of opaque section definitions and remove vm-compiled code *) @@ -78,7 +77,13 @@ val save_proof_admitted val save_proof_proved : ?proof:Proof_global.closed_proof - -> ?pstate: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.t + -> 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..3b77039de5 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -86,14 +86,12 @@ 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 val next_obligation - : ontop:Proof_global.t option - -> Names.Id.t option + : Names.Id.t option -> Genarg.glob_generic_argument option -> Proof_global.t diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 2e97a169cc..02af1904fd 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -39,8 +39,8 @@ open Pputils pr_sep_com spc @@ pr_lconstr_expr env sigma let pr_uconstraint (l, d, r) = - pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ - pr_glob_level r + pr_glob_sort_name l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ + pr_glob_sort_name r let pr_univ_name_list = function | None -> mt () @@ -628,7 +628,6 @@ open Pputils let pr_showable = function | ShowGoal n -> keyword "Show" ++ pr_goal_reference n | ShowProof -> keyword "Show Proof" - | ShowScript -> keyword "Show Script" | ShowExistentials -> keyword "Show Existentials" | ShowUniverses -> keyword "Show Universes" | ShowProofNames -> keyword "Show Conjectures" @@ -1047,7 +1046,7 @@ open Pputils | Some Flags.Current -> [SetOnlyParsing] | Some v -> [SetCompatVersion v])) ) - | VernacArguments (q, args, more_implicits, nargs, mods) -> + | VernacArguments (q, args, more_implicits, nargs, nargs_before_bidi, mods) -> return ( hov 2 ( keyword "Arguments" ++ spc() ++ @@ -1058,22 +1057,23 @@ open Pputils | Impargs.Implicit -> str "[" ++ x ++ str "]" | Impargs.MaximallyImplicit -> str "{" ++ x ++ str "}" | Impargs.NotImplicit -> x in - let rec print_arguments n l = - match n, l with - | Some 0, l -> spc () ++ str"/" ++ print_arguments None l - | _, [] -> mt() - | n, { name = id; recarg_like = k; + let rec print_arguments n nbidi l = + match n, nbidi, l with + | Some 0, _, l -> spc () ++ str"/" ++ print_arguments None nbidi l + | _, Some 0, l -> spc () ++ str"|" ++ print_arguments n None l + | _, _, [] -> mt() + | n, nbidi, { name = id; recarg_like = k; notation_scope = s; implicit_status = imp } :: tl -> spc() ++ pr_br imp (pr_if k (str"!") ++ Name.print id ++ pr_s s) ++ - print_arguments (Option.map pred n) tl + print_arguments (Option.map pred n) (Option.map pred nbidi) tl in let rec print_implicits = function | [] -> mt () | (name, impl) :: rest -> spc() ++ pr_br impl (Name.print name) ++ print_implicits rest in - print_arguments nargs args ++ + print_arguments nargs nargs_before_bidi args ++ if not (List.is_empty more_implicits) then prlist (fun l -> str"," ++ print_implicits l) more_implicits else (mt ()) ++ @@ -1086,7 +1086,8 @@ open Pputils | `Assert -> keyword "assert" | `ExtraScopes -> keyword "extra scopes" | `ClearImplicits -> keyword "clear implicits" - | `ClearScopes -> keyword "clear scopes") + | `ClearScopes -> keyword "clear scopes" + | `ClearBidiHint -> keyword "clear bidirectionality hint") mods) ) | VernacReserve bl -> diff --git a/vernac/record.ml b/vernac/record.ml index f737a8c524..6101e13edd 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -125,7 +125,7 @@ let typecheck_params_and_fields finite def poly pl ps records = let env = EConstr.push_rel_context newps env0 in let poly = match t with - | { CAst.v = CSort (Glob_term.GType []) } -> true | _ -> false in + | { CAst.v = CSort (Glob_term.UAnonymous {rigid=true}) } -> true | _ -> false in let sigma, s = interp_type_evars ~program_mode:false env sigma ~impls:empty_internalization_env t in let sred = Reductionops.whd_allnolet env sigma s in (match EConstr.kind sigma sred with @@ -588,12 +588,14 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity let add_constant_class env sigma cst = let ty, univs = Typeops.type_of_global_in_context env (ConstRef cst) in let r = (Environ.lookup_constant cst env).const_relevance in - let ctx, arity = decompose_prod_assum ty in + let ctx, _ = decompose_prod_assum ty in + let args = Context.Rel.to_extended_vect Constr.mkRel 0 ctx in + let t = mkApp (mkConstU (cst, Univ.make_abstract_instance univs), args) in let tc = { cl_univs = univs; cl_impl = ConstRef cst; cl_context = (List.map (const None) ctx, ctx); - cl_props = [LocalAssum (make_annot Anonymous r, arity)]; + cl_props = [LocalAssum (make_annot Anonymous r, t)]; cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 5ae572541e..8668f01053 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -47,15 +47,20 @@ 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 | 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 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) @@ -91,6 +96,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 *) @@ -405,7 +429,7 @@ let universe_subgraph ?loc g univ = let open Univ in let sigma = Evd.from_env (Global.env()) in let univs_of q = - let q = Glob_term.(GType (UNamed q)) in + let q = Glob_term.(GType q) in (* this function has a nice error message for not found univs *) LSet.singleton (Pretyping.interp_known_glob_level ?loc sigma q) in @@ -540,7 +564,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 +586,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,60 +597,63 @@ 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_name lid local = + let lid = + match lid with + | { 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 + | 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 = 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 ~pstate (local, atts.polymorphic, DefinitionBody kind) - ?hook [(CAst.make ?loc name, pl), (bl, t)]) - | DefineBody (bl,red_option,c,typ_opt) -> - 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; - pstate - ) + 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_start_proof ~atts ~pstate kind l = +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 in + let red_option = match red_option with + | None -> None + | Some r -> + 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 + +(* NB: pstate argument to use combinators easily *) +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 ~pstate ~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 ?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 = (* 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 - if not status then Feedback.feedback Feedback.AddedAxiom; - pstate + let () = save_pstate_proved ~pstate ~opaque:Proof_global.Opaque ~idopt:None in + if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = let open DefAttributes in @@ -804,30 +831,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 ~pstate discharge l : Proof_global.t option = - 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 ~ontop:pstate - in - do_fixpoint local atts.polymorphic l + enforce_locality_exp atts.DefAttributes.locality discharge -let vernac_cofixpoint ~atts ~pstate discharge l = +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 ~ontop:pstate - 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 @@ -883,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) -> @@ -930,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) -> @@ -983,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 @@ -997,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 @@ -1058,18 +1097,42 @@ let vernac_identity_coercion ~atts id qids qidt = (* Type classes *) -let vernac_instance ~atts name bl t props pri = - let open DefAttributes in - let global = not (make_section_locality atts.locality) in +let vernac_instance_program ~atts name bl t props info = 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 + 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_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 = - let open DefAttributes in - let global = not (make_section_locality atts.locality) in Dumpglob.dump_definition (fst id) false "inst"; - 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 @@ -1094,7 +1157,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 @@ -1118,9 +1181,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 *) @@ -1204,6 +1265,36 @@ let vernac_syntactic_definition ~module_local lid x y = Dumpglob.dump_definition lid false "syndef"; Metasyntax.add_syntactic_definition (Global.env()) lid.v x module_local y +let cache_bidi_hints (_name, (gr, ohint)) = + match ohint with + | None -> Pretyping.clear_bidirectionality_hint gr + | Some nargs -> Pretyping.add_bidirectionality_hint gr nargs + +let load_bidi_hints _ r = + cache_bidi_hints r + +let subst_bidi_hints (subst, (gr, ohint as orig)) = + let gr' = subst_global_reference subst gr in + if gr == gr' then orig else (gr', ohint) + +let discharge_bidi_hints (_name, (gr, ohint)) = + if isVarRef gr && Lib.is_in_section gr then None + else + let vars = Lib.variable_section_segment_of_reference gr in + let n = List.length vars in + Some (gr, Option.map ((+) n) ohint) + +let inBidiHints = + let open Libobject in + declare_object { (default_object "BIDIRECTIONALITY-HINTS" ) with + load_function = load_bidi_hints; + cache_function = cache_bidi_hints; + classify_function = (fun o -> Substitute o); + subst_function = subst_bidi_hints; + discharge_function = discharge_bidi_hints; + } + + let warn_arguments_assert = CWarnings.create ~name:"arguments-assert" ~category:"vernacular" (fun sr -> @@ -1216,7 +1307,7 @@ let warn_arguments_assert = (* [nargs_for_red] is the number of arguments required to trigger reduction, [args] is the main list of arguments statuses, [more_implicits] is a list of extra lists of implicit statuses *) -let vernac_arguments ~section_local reference args more_implicits nargs_for_red flags = +let vernac_arguments ~section_local reference args more_implicits nargs_for_red nargs_before_bidi flags = let env = Global.env () in let sigma = Evd.from_env env in let assert_flag = List.mem `Assert flags in @@ -1227,6 +1318,7 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red let default_implicits_flag = List.mem `DefaultImplicits flags in let never_unfold_flag = List.mem `ReductionNeverUnfold flags in let nomatch_flag = List.mem `ReductionDontExposeCase flags in + let clear_bidi_hint = List.mem `ClearBidiHint flags in let err_incompat x y = user_err Pp.(str ("Options \""^x^"\" and \""^y^"\" are incompatible.")) in @@ -1285,6 +1377,9 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red if Option.cata (fun n -> n > num_args) false nargs_for_red then user_err Pp.(str "The \"/\" modifier should be put before any extra scope."); + if Option.cata (fun n -> n > num_args) false nargs_before_bidi then + user_err Pp.(str "The \"&\" modifier should be put before any extra scope."); + let scopes_specified = List.exists Option.has_some scopes in if scopes_specified && clear_scopes_flag then @@ -1396,6 +1491,12 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red let red_modifiers_specified = Option.has_some red_behavior in + let bidi_hint_specified = Option.has_some nargs_before_bidi in + + if bidi_hint_specified && clear_bidi_hint then + err_incompat "clear bidirectionality hint" "&"; + + (* Actions *) if renaming_specified then begin @@ -1428,10 +1529,26 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red strbrk "are relevant for constants only.") end; + if bidi_hint_specified then begin + let n = Option.get nargs_before_bidi in + if section_local then + Pretyping.add_bidirectionality_hint sr n + else + Lib.add_anonymous_leaf (inBidiHints (sr, Some n)) + end; + + if clear_bidi_hint then begin + if section_local then + Pretyping.clear_bidirectionality_hint sr + else + Lib.add_anonymous_leaf (inBidiHints (sr, None)) + end; + if not (renaming_specified || implicits_specified || scopes_specified || - red_modifiers_specified) && (List.is_empty flags) then + red_modifiers_specified || + bidi_hint_specified) && (List.is_empty flags) then warn_arguments_assert sr let default_env () = { @@ -1872,7 +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.t option) ~atts = +let vernac_print ~pstate ~atts = let sigma, env = get_current_or_global_context ~pstate in function | PrintTables -> print_tables () @@ -2029,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 @@ -2060,19 +2175,21 @@ 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 = @@ -2089,31 +2206,34 @@ 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 +(* 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 - | ShowProof -> show_proof ~pstate + | ShowProof -> show_proof ~pstate:None | ShowMatch id -> show_match id - | ShowScript -> assert false (* Only the stm knows the script *) | _ -> user_err (str "This command requires an open proof.") end @@ -2130,11 +2250,10 @@ 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) + 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 - | ShowScript -> assert false (* Only the stm knows the script *) end let vernac_check_guard ~pstate = @@ -2149,26 +2268,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 - (** A global default timeout, controlled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2223,338 +2322,388 @@ let locate_if_not_already ?loc (e, info) = exception End_of_input -(* "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.t option = - let pstate = st.Vernacstate.proof in - vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); +let interp_typed_vernac c ~pstate = + let open Proof_global in + let open Vernacextend in 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 - + | 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); + Proof_global.discard_current 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 + +(* 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 ((discharge,kind),lid,d) -> - with_def_attributes ~atts vernac_definition ~pstate discharge kind lid d + + | 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_def_attributes ~atts vernac_start_proof ~pstate 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) -> - with_def_attributes ~atts vernac_fixpoint ~pstate discharge l + let opens = List.exists (fun ((_,_,_,_,p),_) -> Option.is_empty p) l in + if opens then + VtOpenProof (fun () -> + with_def_attributes ~atts vernac_fixpoint_interactive discharge l) + else + VtDefault (fun () -> + with_def_attributes ~atts vernac_fixpoint discharge l) | VernacCoFixpoint (discharge, l) -> - with_def_attributes ~atts vernac_cofixpoint ~pstate discharge l + let opens = List.exists (fun ((_,_,_,p),_) -> Option.is_empty p) l in + if opens then + VtOpenProof(fun () -> with_def_attributes ~atts vernac_cofixpoint_interactive discharge l) + else + 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) -> - snd @@ with_def_attributes ~atts (vernac_instance ~pstate 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) -> - with_def_attributes ~atts vernac_declare_instance 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; - Some (vernac_require_open_proof ~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, flags) -> - with_section_locality ~atts vernac_arguments qid args more_implicits nargs 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 @@ - vernac_require_open_proof ~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 -> - let pstate = Option.cata (vernac_set_end_tac ~pstate) pstate tac in - Option.cata (vernac_set_used_variables ~pstate) pstate using) - 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) -> - (* XXX: Here we are returning the state! :) *) - let st : Vernacstate.t = Vernacextend.call ~atts opn args ~st in - st.Vernacstate.proof + 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 ~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 @@ -2562,7 +2711,7 @@ let rec interp_expr ?proof ~atts ~st c : Proof_global.t option = the way the proof mode is set there makes the task non trivial without a considerable amount of refactoring. *) -and vernac_load ?proof ~verbosely ~st fname = +and vernac_load ~verbosely ~st fname = let pstate = st.Vernacstate.proof in if there_are_pending_proofs ~pstate then CErrors.user_err Pp.(str "Load is not supported inside proofs."); @@ -2585,7 +2734,7 @@ and vernac_load ?proof ~verbosely ~st fname = try let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) pstate in let pstate = - v_mod (interp_control ?proof ~st:{ st with Vernacstate.proof = pstate }) + v_mod (interp_control ?proof:None ~st:{ st with Vernacstate.proof = pstate }) (parse_sentence proof_mode input) in load_loop ~pstate with diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 12451370c8..d94ddc1aaf 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -42,7 +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.stack option -> (pstate:Proof_global.t -> 'a) -> 'a + +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` *) diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index f946e0596e..b8946fad23 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -81,7 +81,6 @@ type locatable = type showable = | ShowGoal of goal_reference | ShowProof - | ShowScript | ShowExistentials | ShowUniverses | ShowProofNames @@ -362,8 +361,9 @@ type nonrec vernac_expr = vernac_argument_status list (* Main arguments status list *) * (Name.t * Impargs.implicit_kind) list list (* Extra implicit status lists *) * int option (* Number of args to trigger reduction *) * + int option (* Number of args before bidirectional typing *) * [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | - `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | + `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | `ClearBidiHint | `DefaultImplicits ] list | VernacReserve of simple_binder list | VernacGeneralizable of (lident list) option diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 730f5fd6da..6f8a4e8a3c 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -53,14 +53,23 @@ 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 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 -> typed_vernac 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 +92,7 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) -let call opn converted_args ~atts ~st = +let type_vernac 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 ~st = phase := "Checking arguments"; let hunk = callback converted_args in phase := "Executing command"; - hunk ~atts ~st + hunk ~atts with | reraise -> let reraise = CErrors.push reraise in @@ -125,7 +134,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 +160,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..60e371a6d9 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -71,18 +71,27 @@ 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 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 -> typed_vernac 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 type_vernac : 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 -> diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 77f54361da..0fbde1ade5 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -30,10 +30,12 @@ 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) *) } +let pstate st = Option.map Proof_global.get_current_pstate st.proof + let s_cache = ref None let s_proof = ref None @@ -96,17 +98,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 +124,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 diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index dff81ad9bb..b0f3c572e5 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -21,10 +21,12 @@ 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) *) } +val pstate : t -> Proof_global.t option + val freeze_interp_state : marshallable:bool -> t val unfreeze_interp_state : t -> unit @@ -39,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 @@ -61,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 @@ -79,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"] |