diff options
460 files changed, 4712 insertions, 4021 deletions
diff --git a/.github/SUPPORT.md b/.github/SUPPORT.md new file mode 100644 index 0000000000..b6f2e942e9 --- /dev/null +++ b/.github/SUPPORT.md @@ -0,0 +1,28 @@ +# Support # + +Get in touch with the user community and ask questions about Coq on +our [Discourse forum][]. Posts in other languages than English are +explicitly welcome there. There is also a historic mailing list called +the [Coq-Club][] which has lots of subscribers, and an IRC channel +(`irc://irc.freenode.net/#coq`). + +In addition, you may also ask questions about Coq on [Stack +Overflow][] (use the tag [coq][Stack Overflow tag]) or on the +meta-theory of Coq on the [TCS Stack Exchange][] (which also has a +[coq][TCS SE tag] tag). + +You can reach the Coq development team through the [development +category][] of the above mentioned Discourse forum, the [Gitter +channel][], and of course the bug tracker. + +See also [coq.inria.fr/community](https://coq.inria.fr/community.html). + +[Discourse forum]: https://coq.discourse.group +[Coq-Club]: https://sympa.inria.fr/sympa/arc/coq-club +[Stack Overflow]: https://stackoverflow.com +[Stack Overflow tag]: https://stackoverflow.com/questions/tagged/coq +[TCS Stack Exchange]: https://cstheory.stackexchange.com/ +[TCS SE tag]: https://cstheory.stackexchange.com/questions/tagged/coq +[development category]: https://coq.discourse.group/c/coq-development +[Gitter channel]: https://gitter.im/coq/coq +[bug tracker]: https://github.com/coq/coq/issues diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 9e96d3602b..1be10f91d0 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -121,7 +121,7 @@ before_script: OPAM_VARIANT: "+flambda" artifacts: name: "$CI_JOB_NAME" - expire_in: 1 month + expire_in: 2 months # every non build job must set dependencies otherwise all build # artifacts are used together and we may get some random Coq. To that @@ -140,6 +140,7 @@ before_script: name: "$CI_JOB_NAME" paths: - _install_ci/share/doc/coq/ + expire_in: 2 months # set dependencies when using .test-suite-template: @@ -159,6 +160,8 @@ before_script: when: on_failure paths: - test-suite/logs + # Gitlab doesn't support yet "expire_in: never" so we use the instance default + # expire_in: never variables: timeout: "" @@ -177,7 +180,7 @@ before_script: name: "$CI_JOB_NAME.logs" paths: - coqchk.log - expire_in: 1 month + expire_in: 2 months .ci-template: stage: test @@ -241,6 +244,9 @@ build:base+32bit: variables: OPAM_VARIANT: "+32bit" COQ_EXTRA_CONF: "-native-compiler yes" + only: &full-ci + variables: + - $FULL_CI == "true" build:edge+flambda: extends: .build-template @@ -314,6 +320,7 @@ pkg:opam: COQ_VERSION: "8.10" OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" + only: *full-ci .nix-template: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git @@ -341,6 +348,8 @@ pkg:opam: when: on_failure paths: - nix-build-coq.drv-0/*/test-suite/logs + # Gitlab doesn't support yet "expire_in: never" so we use the instance default + # expire_in: never pkg:nix:deploy: extends: .nix-template @@ -443,6 +452,7 @@ test-suite:base+32bit: - build:base+32bit variables: OPAM_VARIANT: "+32bit" + only: *full-ci test-suite:edge+flambda: extends: .test-suite-template @@ -451,6 +461,7 @@ test-suite:edge+flambda: variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" + only: *full-ci test-suite:egde:dune:dev: stage: test @@ -465,6 +476,8 @@ test-suite:egde:dune:dev: when: on_failure paths: - _build/default/test-suite/logs + # Gitlab doesn't support yet "expire_in: never" so we use the instance default + # expire_in: never test-suite:edge+trunk+make: stage: test @@ -491,6 +504,7 @@ test-suite:edge+trunk+make: - test-suite/logs expire_in: 1 week allow_failure: true + only: *full-ci test-suite:edge+trunk+dune: stage: test @@ -519,6 +533,7 @@ test-suite:edge+trunk+dune: - _build/default/test-suite/logs expire_in: 1 week allow_failure: true + only: *full-ci test-suite:base+async: extends: .test-suite-template @@ -543,6 +558,7 @@ validate:base+32bit: - build:base+32bit variables: OPAM_VARIANT: "+32bit" + only: *full-ci validate:edge+flambda: extends: .validate-template @@ -551,6 +567,7 @@ validate:edge+flambda: variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" + only: *full-ci validate:quick: extends: .validate-template @@ -6,7 +6,7 @@ ## To avoid spam issues, we use by default a pseudo-email <login@gforge> ## for all persons that haven't made commits with real emails ## -## If you're mentionned here and want to update your information, +## If you're mentioned here and want to update your information, ## either amend this file and commit it, or contact the coqdev list Abhishek Anand <abhishek.anand.iitg@gmail.com> Abhishek Anand (@brixpro-home) <abhishek.anand.iitg@gmail.com> diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 31fa3d2c4a..f0e17909c1 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -31,7 +31,7 @@ account). You can file a bug for any of the following: It would help if you search the existing issues before reporting a bug. This can be difficult, so consider it extra credit. We don't mind duplicate bug reports. If unsure, you are always very welcome to ask on our [Discourse forum][] -or [Gitter chat][] before, after, or while writting a bug report +or [Gitter chat][] before, after, or while writing a bug report When it applies, it's extremely helpful for bug reports to include sample code, and much better if the code is self-contained and complete. It's not @@ -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) diff --git a/Makefile.build b/Makefile.build index f0c9e6af01..c76c14f2de 100644 --- a/Makefile.build +++ b/Makefile.build @@ -150,7 +150,7 @@ endif ########################################################################### -# This include below will lauch the build of all .d. +# This include below will launch the build of all .d. # The - at front is for disabling warnings about currently missing ones. # For creating the missing .d, make will recursively build things like # coqdep_boot (for the .v.d files) or coqpp (for .mlg -> .ml -> .ml.d). diff --git a/Makefile.dev b/Makefile.dev index 13b85dfad4..6057696375 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -8,7 +8,7 @@ ## # (see LICENSE file for the text of the license) ## ########################################################################## -# Extra targets for developpers : +# Extra targets for developers : # debug printers, revision, partial targets ... ######################### diff --git a/Makefile.doc b/Makefile.doc index 25d146000b..94642e702f 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -167,7 +167,7 @@ doc/stdlib/Library.pdf: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Li $(PDFLATEX) -interaction=batchmode Library;\ ../tools/show_latex_messages -no-overfull Library.log) -### Standard library (full version if you're crazy enouth to try) +### Standard library (full version if you're crazy enough to try) doc/stdlib/FullLibrary.tex: doc/stdlib/Library.tex sed -e 's/Library.coqdoc/FullLibrary.coqdoc/g;s/\\begin{document}/\\newcommand{\\textlambda}{\\ensuremath{\\lambda}}\\newcommand{\\textPi}{\\ensuremath{\\Pi}}\\begin{document}/' $< > $@ diff --git a/Makefile.dune b/Makefile.dune index ebf74978a9..88055d62dc 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -5,7 +5,7 @@ .PHONY: coq coqide coqide-server # Package targets .PHONY: quickbyte quickopt quickide # Partial / quick developer targets .PHONY: refman-html stdlib-html apidoc # Documentation targets -.PHONY: test-suite release # Accesory targets +.PHONY: test-suite release # Accessory targets .PHONY: ocheck trunk ireport clean # Maintenance targets # use DUNEOPT=--display=short for a more verbose build diff --git a/Makefile.ide b/Makefile.ide index 4cec7aa443..89c1f246db 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -77,7 +77,7 @@ ADWAITASHARE=$(shell ls -d /usr/local/Cellar/adwaita-icon-theme/*)/share .PHONY: coqide coqide-opt coqide-byte coqide-bindings coqide-files coqide-binaries .PHONY: ide-toploop ide-byteloop ide-optloop -# target to build CoqIde (native version) and the stuff needed to lauch it +# target to build CoqIde (native version) and the stuff needed to launch it coqide: coqide-files coqide-opt theories/Init/Prelude.$(VO) $(TOPBIN) # target to build CoqIde (in native and byte versions), and no more @@ -28,7 +28,6 @@ environment for semi-interactive development of machine-checked proofs. [![Arch package][arch-badge]][arch-link] [![Chocolatey package][chocolatey-badge]][chocolatey-link] [![Homebrew package][homebrew-badge]][homebrew-link] -[![MacPorts package][macports-badge]][macports-link] [![nixpkgs unstable package][nixpkgs-badge]][nixpkgs-link] [repology-badge]: https://repology.org/badge/latest-versions/coq.svg @@ -88,7 +87,7 @@ development team: See also [coq.inria.fr/community](https://coq.inria.fr/community.html). -## Bugs report +## Bug reports Please report any bug / feature request in [our issue tracker](https://github.com/coq/coq/issues). diff --git a/checker/check.ml b/checker/check.ml index a2c8a0f25d..903258daef 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -50,7 +50,8 @@ let pr_path sp = type compilation_unit_name = DirPath.t -type seg_proofs = Constr.constr Future.computation array +type seg_univ = Univ.ContextSet.t * bool +type seg_proofs = (Opaqueproof.cooking_info list * int * Constr.constr option) array type library_t = { library_name : compilation_unit_name; @@ -90,7 +91,6 @@ let register_loaded_library m = (* Map from library names to table of opaque terms *) let opaque_tables = ref LibraryMap.empty -let opaque_univ_tables = ref LibraryMap.empty let access_opaque_table dp i = let t = @@ -98,18 +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 access_opaque_univ_table dp i = - try - let t = LibraryMap.find dp !opaque_univ_tables in - assert (i < Array.length t); - Some t.(i) - with Not_found -> None +let access_discharge = Cooking.cook_constr + +let indirect_accessor = { + Opaqueproof.access_proof = access_opaque_table; + Opaqueproof.access_discharge = access_discharge; +} -let () = - Opaqueproof.set_indirect_opaque_accessor access_opaque_table; - Opaqueproof.set_indirect_univ_accessor access_opaque_univ_table +let () = Mod_checking.set_indirect_accessor indirect_accessor let check_one_lib admit senv (dir,m) = let md = m.library_compiled in @@ -335,8 +336,7 @@ let intern_from_file ~intern_mode (dir, f) = let ch = System.with_magic_number_check raw_intern_library f in 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:'a option), _, udg = marshal_in_segment f ch in - let (discharging:'a option), _, _ = marshal_in_segment f ch in + let (opaque_csts:seg_univ option), _, udg = 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 @@ -349,12 +349,12 @@ 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 Flags.if_verbose chk_pp (str " (was a vio file) "); - Option.iter (fun (_,_,b) -> if not b then + Option.iter (fun (_,b) -> if not b then user_err ~hdr:"intern_from_file" (str "The file "++str f++str " is still a .vio")) opaque_csts; @@ -372,13 +372,9 @@ let intern_from_file ~intern_mode (dir, f) = with e -> Flags.if_verbose chk_pp (str" failed!]" ++ fnl ()); raise e in depgraph := LibraryMap.add sd.md_name sd.md_deps !depgraph; Option.iter (fun table -> opaque_tables := LibraryMap.add sd.md_name table !opaque_tables) table; - Option.iter (fun (opaque_csts,_,_) -> - opaque_univ_tables := - LibraryMap.add sd.md_name opaque_csts !opaque_univ_tables) - opaque_csts; let extra_cst = Option.default Univ.ContextSet.empty - (Option.map (fun (_,cs,_) -> cs) opaque_csts) in + (Option.map (fun (cs,_) -> cs) opaque_csts) in mk_library sd md f table digest extra_cst let get_deps (dir, f) = diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index 4f4527ca12..b66e198234 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -75,8 +75,7 @@ let check_arity env ar1 ar2 = match ar1, ar2 with (* template_level is inferred by indtypes, so functor application can produce a smaller one *) | (RegularArity _ | TemplateArity _), _ -> false -let check_kelim k1 k2 = - List.for_all (fun x -> List.mem_f Sorts.family_equal x k2) k1 +let check_kelim k1 k2 = Sorts.family_leq k1 k2 (* Use [eq_ind_chk] because when we rebuild the recargs we have lost the knowledge of who is the canonical version. diff --git a/checker/include b/checker/include index 3ffc301724..411321cb3e 100644 --- a/checker/include +++ b/checker/include @@ -3,7 +3,7 @@ (* Caml script to include for debugging the checker. Usage: from the checker/ directory launch ocaml toplevel and then type #use"include";; - This command loads the relevent modules, defines some pretty + This command loads the relevant modules, defines some pretty printers, and provides functions to interactively check modules (mainly run_l and norec). *) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 1dd16f1630..0684623a81 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -8,6 +8,13 @@ open Environ (** {6 Checking constants } *) +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 *) @@ -16,23 +23,29 @@ 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) + in let () = - match Environ.body_of_constant_body env cb with + match body with | Some bd -> - let j = infer env' (fst bd) in + let j = infer env' bd in (try conv_leq env' j.uj_type ty with NotConvertible -> Type_errors.error_actual_type env j ty) | None -> () diff --git a/checker/mod_checking.mli b/checker/mod_checking.mli index 6cff3e6b8c..7aa1f837a0 100644 --- a/checker/mod_checking.mli +++ b/checker/mod_checking.mli @@ -8,4 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +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 5cbf0ff298..4a4c8d803c 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -53,7 +53,6 @@ let v_enum name n = Sum(name,n,[||]) let v_pair v1 v2 = v_tuple "*" [|v1; v2|] let v_bool = v_enum "bool" 2 let v_unit = v_enum "unit" 1 -let v_ref v = v_tuple "ref" [|v|] let v_set v = let rec s = Sum ("Set.t",1, @@ -70,13 +69,6 @@ let v_hmap vk vd = v_map Int (v_map vk vd) let v_pred v = v_pair v_bool (v_set v) -(* lib/future *) -let v_computation f = - Annot ("Future.computation", - v_ref - (v_sum "Future.comput" 0 - [| [| Fail "Future.ongoing" |]; [| f |] |])) - (** kernel/names *) let v_id = String @@ -139,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 *) @@ -265,7 +257,7 @@ let v_one_ind = v_tuple "one_inductive_body" Array v_constr; Int; Int; - List v_sortfam; + v_sortfam; Array (v_pair v_rctxt v_constr); Array Int; Array Int; @@ -391,6 +383,22 @@ let v_libsum = let v_lib = Tuple ("library",[|v_compiled_lib;v_libraryobjs|]) -let v_opaques = Array (v_computation 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",[|Array (v_computation v_context_set);v_context_set;v_bool|])) + Opt (Tuple ("univopaques",[|v_context_set;v_bool|])) diff --git a/clib/iStream.mli b/clib/iStream.mli index 40d579be60..e56f066c5e 100644 --- a/clib/iStream.mli +++ b/clib/iStream.mli @@ -31,7 +31,7 @@ val cons : 'a -> 'a t -> 'a t (** Append an element in front of a stream. *) val thunk : (unit -> ('a,'a t) u) -> 'a t -(** Internalize the lazyness of a stream. *) +(** Internalize the laziness of a stream. *) val make : ('a -> ('b, 'a) u) -> 'a -> 'b t (** Coiteration constructor. *) diff --git a/configure.ml b/configure.ml index 57f31fec4c..3ced82718e 100644 --- a/configure.ml +++ b/configure.ml @@ -451,7 +451,7 @@ let coq_profile_flag = if !prefs.profile then "-p" else "" let coq_annot_flag = if !prefs.annot then "-annot" else "" let coq_bin_annot_flag = if !prefs.bin_annot then "-bin-annot" else "" -(* This variable can be overriden only for debug purposes, use with +(* This variable can be overridden only for debug purposes, use with care. *) let coq_safe_string = "-safe-string" let coq_strict_sequence = "-strict-sequence" 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 26e1e25fb9..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 () @@ -499,7 +508,7 @@ let print_rules fmt (name, rules) = let pr fmt l = print_list fmt (fun fmt r -> fprintf fmt "(%a)" GramExt.print_extrule r) l in match rules with | [([SymbEntry (e, None)], [Some s], { code = c } )] when String.trim c = s -> - (* This is a horrible hack to work aroud limitations of camlp5 regarding + (* This is a horrible hack to work around limitations of camlp5 regarding factorization of parsing rules. It allows to recognize rules of the form [ entry(x) ] -> [ x ] so as not to generate a proxy entry and reuse the same entry directly. *) 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/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index c3f3a97ff5..7c8f73c7e4 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -285,9 +285,9 @@ SET RESULT_INSTALLDIR_WFMT=%DESTCOQ% SET TARGET_ARCH=%ARCH%-w64-mingw32
SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash
-REM Convert pathes to various formats
+REM Convert paths to various formats
REM WFMT = windows format (C:\..) Used in this batch file.
-REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH varible, which is : separated, so C: doesn't work.
+REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH variable, which is : separated, so C: doesn't work.
REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /.
SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/%
@@ -429,13 +429,13 @@ ECHO ========== BATCH FUNCTIONS ========== REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789
ECHO -arch ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit
ECHO -mode ^<mingwincygwin = install coq in default cygwin mingw sysroot^>
- ECHO ^<absoloute = install coq in -destcoq absulute path^>
+ ECHO ^<absolute = install coq in -destcoq absolute path^>
ECHO ^<relocatable = install relocatable coq in -destcoq path^>
ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis)
ECHO -ocaml ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N)
ECHO -make ^<Y or N^> install GNU Make in Coq folder (Y) or not (N)
ECHO -destcyg ^<path to cygwin destination folder^>
- ECHO -destcoq ^<path to coq destination folder (mode=absoloute/relocatable)^>
+ ECHO -destcoq ^<path to coq destination folder (mode=absolute/relocatable)^>
ECHO -setup ^<cygwin setup program name^> (auto adjusted to -arch)
ECHO -proxy ^<internet proxy^>
ECHO -cygrepo ^<cygwin download repository^>
diff --git a/dev/build/windows/ReadMe.txt b/dev/build/windows/ReadMe.txt index a392115ea4..052014824f 100644 --- a/dev/build/windows/ReadMe.txt +++ b/dev/build/windows/ReadMe.txt @@ -43,7 +43,7 @@ paths like "C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys DLL. The missing piece is a posix shell running on plain Windows (without msys or -Cygwin DLL) and not beeing a binary from obscure sources. I am working on it ... +Cygwin DLL) and not being a binary from obscure sources. I am working on it ... Since compiling gcc and binutils takes a while and it is not of much use without a shell, the building of these components is currently disabled. OCaml is built @@ -131,7 +131,7 @@ mingwinCygwin: Install coq in the default Cygwin mingw sysroot folder. Todo: The coq share folder should be configured to e.g. /share/coq. As is, coqc scans the complete share folder, which slows it down 5x for short files. -absoloute: Install coq in the absolute path given with -destcoq. +absolute: Install coq in the absolute path given with -destcoq. The resulting Coq will not be relocatable. That is the root folder must not be renamed/moved. @@ -274,11 +274,11 @@ Default value: N ===== -cygquiet ===== -Control if the Cygwin setup runs quitely or interactive. +Control if the Cygwin setup runs quietly or interactive. Possible values: -Y: Install Cygwin quitely without user interaction. +Y: Install Cygwin quietly without user interaction. N: Install Cygwin interactively (allows to select additional packages). @@ -299,7 +299,7 @@ The version of Coq to download and compile. Possible values: 8.4pl6, 8.5pl2, 8.5pl3, 8.6 (download from https://coq.inria.fr/distrib/V$COQ_VERSION/files/coq-<version>.tar.gz) Others versions might work, but are untested. - 8.4 is only tested in mode=absoloute + 8.4 is only tested in mode=absolute git-v8.6, git-trunk (download from https://github.com/coq/coq/archive/<version without git->.zip) @@ -344,12 +344,12 @@ selecting more packages) ==================== TODO ==================== - Check for spaces in destination paths -- Check for = signs in all paths (DOS commands don't work with pathes with = in it, possibly even when quoted) +- Check for = signs in all paths (DOS commands don't work with paths with = in it, possibly even when quoted) - Installer doesn't remove OCAMLLIB environment variables (it is in the script, but doesn't seem to work) - CoqIDE doesn't find theme files - Finish / test mingw_in_Cygwin mode (coqide doesn't start, coqc slow cause of scanning complete share folder) -- Possibly create/login as specific user to bash (not sure if it makes sense - nead to create additional bash login link then) -- maybe move share/doc/menhir somehwere else (reduces coqc startup time) +- Possibly create/login as specific user to bash (not sure if it makes sense - need to create additional bash login link then) +- maybe move share/doc/menhir somewhere else (reduces coqc startup time) - Use original installed file list for removing files in uninstaller ==================== Issues with relocation ==================== diff --git a/dev/build/windows/difftar-folder.sh b/dev/build/windows/difftar-folder.sh index 3bba451ec6..543ca972cd 100644 --- a/dev/build/windows/difftar-folder.sh +++ b/dev/build/windows/difftar-folder.sh @@ -40,7 +40,7 @@ fi # Get path prefix if --strip is used if [ "$strip" -gt 0 ] ; then - # Get the path/name of the first file from teh tar and extract the first $strip path components + # Get the path/name of the first file from the tar and extract the first $strip path components # This assumes that the first file in the tar file has at least $strip many path components prefix=$(tar -t -f "$tarfile" | head -1 | cut -d / -f -$strip)/ else diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index d737632638..549f70e8fe 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -765,7 +765,7 @@ function make_ncurses { # gettext make/make install work anyway # # CONFIGURE PARAMETERS - # --enable-term-driver --enable-sp-funcs is rewuired for mingw (see README.MinGW) + # --enable-term-driver --enable-sp-funcs is required for mingw (see README.MinGW) # additional changes # ADD --with-pkg-config # ADD --enable-pc-files @@ -1281,7 +1281,7 @@ function copy_coq_objects { done } -# Copy required GTK config and suport files +# Copy required GTK config and support files function copy_coq_gtk { echo 'gtk-theme-name = "Default"' > "$PREFIX/etc/gtk-3.0/gtkrc" diff --git a/dev/build/windows/patches_coq/pkg-config.c b/dev/build/windows/patches_coq/pkg-config.c index e4fdcd4d7d..c4c7ec2bff 100755 --- a/dev/build/windows/patches_coq/pkg-config.c +++ b/dev/build/windows/patches_coq/pkg-config.c @@ -1,5 +1,5 @@ // MinGW personality wrapper for pkgconf -// This is an excutable replacement for the shell scripts /bin/ARCH-pkg-config +// This is an executable replacement for the shell scripts /bin/ARCH-pkg-config // Compile with e.g. // gcc pkg-config.c -DARCH=x86_64-w64-mingw32 -o pkg-config.exe // gcc pkg-config.c -DARCH=i686-w64-mingw32 -o pkg-config.exe diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 98ea594366..408d36df7f 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -31,7 +31,7 @@ PR by running GitLab CI on your private branches. To do so follow these steps: 6. You are encouraged to go to the CI / CD general settings and increase the timeout from 1h to 2h for better reliability. -Now everytime you push (including force-push unless you changed the default +Now every time you push (including force-push unless you changed the default GitLab setting) to your fork on GitHub, it will be synchronized on GitLab and CI will be run. You will receive an e-mail with a report of the failures if there are some. 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/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/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/10185-SkySkimmer-instance-no-bang.sh b/dev/ci/user-overlays/10185-SkySkimmer-instance-no-bang.sh new file mode 100644 index 0000000000..c584438b21 --- /dev/null +++ b/dev/ci/user-overlays/10185-SkySkimmer-instance-no-bang.sh @@ -0,0 +1,6 @@ +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 + +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/doc/MERGING.md b/dev/doc/MERGING.md index c9eceb1270..66f5a96802 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -92,7 +92,7 @@ When fixes are ready, there are two cases to consider: Once all reviewers approved the PR, the assignee is expected to check that CI completed without relevant failures, and that the PR comes with appropriate documentation and test cases. If not, they should leave a comment on the PR and -put the approriate label. Otherwise, they are expected to merge the PR using the +put the appropriate label. Otherwise, they are expected to merge the PR using the [merge script](../tools/merge-pr.sh). When CI has a few failures which look spurious, restarting the corresponding diff --git a/dev/doc/archive/naming-conventions.tex b/dev/doc/archive/naming-conventions.tex index 0b0811d81b..8b0b14efb8 100644 --- a/dev/doc/archive/naming-conventions.tex +++ b/dev/doc/archive/naming-conventions.tex @@ -570,11 +570,11 @@ Example: \formula{eq\_true\_neg: \~{} eq\_true b <-> eq\_true (negb b)}. Zero on domain {\D} & D0 & (notation \verb=0=)\\ One on domain {\D} & D1 (if explicitly defined) & (notation \verb=1=)\\ Successor on domain {\D} & Dsucc\\ -Predessor on domain {\D} & Dpred\\ -Addition on domain {\D} & Dadd/Dplus\footnote{Coq historically uses \texttt{plus} and \texttt{mult} for addition and multiplication which are inconsistent notations, the recommendation is to use \texttt{add} and \texttt{mul} except in existng libraries that already use \texttt{plus} and \texttt{mult}} +Predecessor on domain {\D} & Dpred\\ +Addition on domain {\D} & Dadd/Dplus\footnote{Coq historically uses \texttt{plus} and \texttt{mult} for addition and multiplication which are inconsistent notations, the recommendation is to use \texttt{add} and \texttt{mul} except in existing libraries that already use \texttt{plus} and \texttt{mult}} & (infix notation \verb=+= [50,L])\\ Multiplication on domain {\D} & Dmul/Dmult\footnotemark[\value{footnote}] & (infix notation \verb=*= [40,L]))\\ -Soustraction on domain {\D} & Dminus & (infix notation \verb=-= [50,L])\\ +Subtraction on domain {\D} & Dminus & (infix notation \verb=-= [50,L])\\ Opposite on domain {\D} & Dopp (if any) & (prefix notation \verb=-= [35,R]))\\ Inverse on domain {\D} & Dinv (if any) & (prefix notation \verb=/= [35,R]))\\ Power on domain {\D} & Dpower & (infix notation \verb=^= [30,R])\\ diff --git a/dev/doc/archive/versions-history.tex b/dev/doc/archive/versions-history.tex index 25dabad497..46516dd4e4 100644 --- a/dev/doc/archive/versions-history.tex +++ b/dev/doc/archive/versions-history.tex @@ -372,7 +372,7 @@ Coq V8.4pl5& released 22 October 2014 & \\ Coq V8.4pl6& released 9 April 2015 & \\ Coq V8.5 beta1 & released 21 January 2015 & \feature{computation via compilation to OCaml} [22-1-2013]\\ -&& \feature{asynchonous evaluation} [8-8-2013]\\ +&& \feature{asynchronous evaluation} [8-8-2013]\\ && \feature{new proof engine deployed} [2-11-2013]\\ && \feature{universe polymorphism} [6-5-2014]\\ && \feature{primitive projections} [6-5-2014]\\ diff --git a/dev/doc/build-system.dev.txt b/dev/doc/build-system.dev.txt index b0a2b04121..6bbf83aa7e 100644 --- a/dev/doc/build-system.dev.txt +++ b/dev/doc/build-system.dev.txt @@ -9,13 +9,13 @@ HISTORY: * March 2010 (Pierre Letouzey). Revised build system. In particular, no more stage1,2,3 : - - Stage3 was removed some time ago when coqdep was splitted into + - Stage3 was removed some time ago when coqdep was split into coqdep_boot and full coqdep. - Stage1,2 were replaced by brutal inclusion of all .d at the start of Makefile.build, without trying to guess what could be done at what time. Some initial inclusions hence _fail_, but "make" tries again later and succeed. - - Btw, .ml4 are explicitely turned into .ml files, which stay after build. + - Btw, .ml4 are explicitly turned into .ml files, which stay after build. By default, they are in binary ast format, see READABLE_ML4 option. * February 2014 (Pierre Letouzey). @@ -87,8 +87,8 @@ Cons: clear-text generated .ml. -Makefiles hierachy ------------------- +Makefiles hierarchy +------------------- The Makefile is separated in several files : @@ -101,7 +101,7 @@ The Makefile is separated in several files : FIND_SKIP_DIRS ---------------- +-------------- The recommended style of using FIND_SKIP_DIRS is for example diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 49251d61a1..372e40a0b7 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -108,14 +108,14 @@ automatically. You can use `ocamldebug` with Dune; after a build, do: ``` -dune exec dev/dune-dbg +dune exec dev/dune-dbg /path/to/foo.v (ocd) source dune_db ``` or ``` -dune exec dev/dune-dbg checker +dune exec dev/dune-dbg checker Foo (ocd) source dune_db ``` @@ -124,6 +124,8 @@ refined, so you need to build enough of Coq once to use this target [it will then correctly compute the deps and rebuild if you call the script again] This will be fixed in the future. +For running in emacs, use `coqdev-ocamldebug` from `coqdev.el`. + ## Dropping from coqtop: After doing `make -f Makefile.dune voboot`, the following commands should work: diff --git a/dev/doc/build-system.txt b/dev/doc/build-system.txt index 8cefe699cc..a14781a058 100644 --- a/dev/doc/build-system.txt +++ b/dev/doc/build-system.txt @@ -18,8 +18,8 @@ See http://www.gnu.org/software/make/manual/make.htmlPrerequisite-Types * Annotation before commands: +/-/@ a command starting by - is always successful (errors are ignored) -a command starting by + is runned even if option -n is given to make -a command starting by @ is not echoed before being runned +a command starting by + is run even if option -n is given to make +a command starting by @ is not echoed before being run * Custom functions @@ -36,7 +36,7 @@ If the file given to -include doesn't exist, make tries to build it, and even retries again if necessary, but doesn't care if this build finally fails. We used to rely on this "feature", but this should not be the case anymore. We kept "-include" instead of "include" for -avoiding warnings about initially non-existant files. +avoiding warnings about initially non-existent files. Changes (for old-timers) ------------------------ diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 7221c3de56..339ac2d9b7 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1278,7 +1278,7 @@ next_global_ident_away true -> next_ident_away_in_goal next_global_ident_away false -> next_global_ident_away ``` -### Cleaning in commmand.ml +### Cleaning in command.ml Functions about starting/ending a lemma are in lemmas.ml Functions about inductive schemes are in indschemes.ml @@ -1593,7 +1593,7 @@ Other kinds of objects: #### Writing subst_thing functions -The subst_thing shoud not copy the thing if it hasn't actually +The subst_thing should not copy the thing if it hasn't actually changed. There are some cool emacs macros in dev/objects.el to help writing subst functions this way quickly and without errors. Also there are *_smartmap functions in Util. diff --git a/dev/doc/econstr.md b/dev/doc/econstr.md index bb17e8fb62..16abf3f519 100644 --- a/dev/doc/econstr.md +++ b/dev/doc/econstr.md @@ -25,7 +25,7 @@ val kind : Evd.evar_map -> t -> (t, t, ESorts.t, EInstance.t) Constr.kind_of_ter Essentially, each time it sees an evar which happens to be defined in the provided evar-map, it replaces it with the corresponding body and carries on. -Due to universe unification occuring at the tactic level, the same goes for +Due to universe unification occurring at the tactic level, the same goes for universe instances and sorts. See the `ESort` and `EInstance` modules in `EConstr`. diff --git a/dev/doc/proof-engine.md b/dev/doc/proof-engine.md index 774552237a..a2c8d2f5ac 100644 --- a/dev/doc/proof-engine.md +++ b/dev/doc/proof-engine.md @@ -121,7 +121,7 @@ a limited set of derivation rules), it is recommended to generate proofs as much as possible by refining in ML tactics when it is possible and easy enough. Indeed, this prevents dependence on fragile constructions such as unification. -Obviously, it does not forbid the use of tacticals to mimick what one would do +Obviously, it does not forbid the use of tacticals to mimic what one would do in Ltac. Each Ltac primitive has a corresponding ML counterpart with simple semantics. A list of such tacticals can be found in the `Tacticals` module. Most of them are a porting of the tacticals from the old engine to the new one, so diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 189d6f9fa5..452160ea5a 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -113,7 +113,7 @@ - [ ] Upload the new version of the reference manual to the website. *TODO: setup some continuous deployment for this.* - [ ] Merge the website update, publish the release - and send annoucement e-mails. + and send announcement e-mails. - [ ] Ping **@Zimmi48** to publish a new version on Zenodo. *TODO: automate this.* - [ ] Close the milestone diff --git a/dev/doc/universes.md b/dev/doc/universes.md index c276603ed2..026c3830a2 100644 --- a/dev/doc/universes.md +++ b/dev/doc/universes.md @@ -163,9 +163,9 @@ only, it's just a matter of using `Evd.fresh_global` / The universe graph ------------------ -To accomodate universe polymorphic definitions, the graph structure in +To accommodate universe polymorphic definitions, the graph structure in kernel/univ.ml was modified. The new API forces every universe to be -declared before it is mentionned in any constraint. This forces to +declared before it is mentioned in any constraint. This forces to declare every universe to be >= Set or > Set. Every universe variable introduced during elaboration is >= Set. Every _global_ universe is now declared explicitly > Set, _after_ typechecking the definition. In diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md index 48671c03b6..e23d1234f7 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -437,7 +437,7 @@ Searches for objects that satisfy a list of constraints. If `${positiveConstrain * Type pattern: `${constraintType} = "type_pattern"`; `${constraintValue}` is a pattern (???: an open gallina term) string. * SubType pattern: `${constraintType} = "subtype_pattern"`; `${constraintValue}` is a pattern (???: an open gallina term) string. * In module: `${constraintType} = "in_module"`; `${constraintValue}` is a list of strings specifying the module/directory structure. -* Include blacklist: `${constraintType} = "include_blacklist"`; `${constraintValue}` *is ommitted*. +* Include blacklist: `${constraintType} = "include_blacklist"`; `${constraintValue}` *is omitted*. ------------------------------- @@ -3,7 +3,7 @@ (public_name coq.top_printers) (synopsis "Coq's Debug Printers") (wrapped false) - (modules :standard) + (modules top_printers) (optional) (libraries coq.toplevel coq.plugins.ltac)) @@ -11,7 +11,7 @@ (targets dune-dbg) (deps dune-dbg.in ../checker/coqchk.bc - ../topbin/coqtop_byte_bin.bc + ../topbin/coqc_bin.bc ; This is not enough as the call to `ocamlfind` will fail :/ top_printers.cma) (action (copy dune-dbg.in dune-dbg))) diff --git a/dev/dune-dbg.in b/dev/dune-dbg.in index 80ad0500e0..bd0a837938 100755 --- a/dev/dune-dbg.in +++ b/dev/dune-dbg.in @@ -3,11 +3,14 @@ # Run in a proper install dune env. case $1 in checker) + shift exe=_build/default/checker/coqchk.bc ;; *) - exe=_build/default/topbin/coqtop_byte_bin.bc + exe=_build/default/topbin/coqc_bin.bc ;; esac -ocamldebug $(ocamlfind query -recursive -i-format coq.top_printers) -I +threads -I dev $exe +emacs="${INSIDE_EMACS:+-emacs}" + +ocamldebug $emacs $(ocamlfind query -recursive -i-format coq.top_printers) -I +threads -I dev $exe "$@" diff --git a/dev/lint-commits.sh b/dev/lint-commits.sh index d8043558eb..96c92e3162 100755 --- a/dev/lint-commits.sh +++ b/dev/lint-commits.sh @@ -34,6 +34,6 @@ if [ "${#bad[@]}" != 0 ] then >&2 echo "Whitespace errors!" >&2 echo "In commits ${bad[*]}" - >&2 echo "If you use emacs, you can prevent this kind of error from reocurring by installing ws-butler and enabling ws-butler-convert-leading-tabs-or-spaces." + >&2 echo "If you use emacs, you can prevent this kind of error from reoccurring by installing ws-butler and enabling ws-butler-convert-leading-tabs-or-spaces." exit 1 fi diff --git a/dev/nsis/coq.nsi b/dev/nsis/coq.nsi index f48013cf2e..b4c5d3d528 100755 --- a/dev/nsis/coq.nsi +++ b/dev/nsis/coq.nsi @@ -6,7 +6,7 @@ ;SetCompress off SetCompressor lzma -; Comment out after debuging. +; Comment out after debugging. ; The VERSION should be passed as an argument at compile time using : ; diff --git a/dev/tools/coqdev.el b/dev/tools/coqdev.el index c6687b9731..b89ae67a82 100644 --- a/dev/tools/coqdev.el +++ b/dev/tools/coqdev.el @@ -85,6 +85,35 @@ Note that this function is executed before _Coqproject is read if it exists." (setq-local coq-prog-name (concat dir "bin/coqtop"))))) (add-hook 'hack-local-variables-hook #'coqdev-setup-proofgeneral) +(defvar coqdev-ocamldebug-command "dune exec dev/dune-dbg" + "Command run by `coqdev-ocamldebug'") + +(defun coqdev-ocamldebug () + "Runs a command in an ocamldebug buffer." + (interactive) + (let* ((dir (read-directory-name "Run from directory: " + (coqdev-default-directory))) + (name "ocamldebug-coq") + (buffer-name (concat "*" name "*"))) + (pop-to-buffer buffer-name) + (unless (comint-check-proc buffer-name) + (setq default-directory dir) + (setq coqdev-ocamldebug-command + (read-from-minibuffer "Command to run: " + coqdev-ocamldebug-command)) + (let* ((cmdlist (tuareg--split-args coqdev-ocamldebug-command)) + (cmdlist (mapcar #'substitute-in-file-name cmdlist))) + (apply #'make-comint name + (car cmdlist) + nil + (cdr cmdlist)) + (set-process-filter (get-buffer-process (current-buffer)) + #'ocamldebug-filter) + (set-process-sentinel (get-buffer-process (current-buffer)) + #'ocamldebug-sentinel) + (ocamldebug-mode))) + (ocamldebug-set-buffer))) + ;; This Elisp snippet adds a regexp parser for the format of Anomaly ;; backtraces (coqc -bt ...), to the error parser of the Compilation ;; mode (C-c C-c: "Compile command: ..."). File locations in traces 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/memo-v8.tex b/dev/v8-syntax/memo-v8.tex index ae4b569b36..84894b6f7c 100644 --- a/dev/v8-syntax/memo-v8.tex +++ b/dev/v8-syntax/memo-v8.tex @@ -55,7 +55,7 @@ _ are allowed after the first character. Quoted strings are used typically to give a filename (which may not be a regular identifier). As before they are written between double quotes ("). Unlike for V7, there is no escape character: characters -are written normaly but the double quote which is doubled. +are written normally but the double quote which is doubled. \section{Main changes in terms w.r.t. V7} @@ -252,7 +252,7 @@ became \TERM{context}. Syntax is unified with subterm matching. \subsection{Occurrences} -To avoid ambiguity between a numeric literal and the optionnal +To avoid ambiguity between a numeric literal and the optional occurrence numbers of this term, the occurrence numbers are put after the term itself. This applies to tactic \TERM{pattern} and also \TERM{unfold} 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/10167-orpat-mixfix.rst b/doc/changelog/02-specification-language/10167-orpat-mixfix.rst new file mode 100644 index 0000000000..e3c3923348 --- /dev/null +++ b/doc/changelog/02-specification-language/10167-orpat-mixfix.rst @@ -0,0 +1,12 @@ +- Require parentheses around nested disjunctive patterns, so that pattern and + term syntax are consistent; match branch patterns no longer require + parentheses for notation at level 100 or more. Incompatibilities: + + + in :g:`match p with (_, (0|1)) => ...` parentheses may no longer be + omitted around :n:`0|1`. + + notation :g:`(p | q)` now potentially clashes with core pattern syntax, + and should be avoided. ``-w disj-pattern-notation`` flags such :cmd:`Notation`. + + see :ref:`extendedpatternmatching` for details + (`#10167 <https://github.com/coq/coq/pull/10167>`_, + by Georges Gonthier). 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/09288-injection-as.rst b/doc/changelog/04-tactics/09288-injection-as.rst new file mode 100644 index 0000000000..6a74551f06 --- /dev/null +++ b/doc/changelog/04-tactics/09288-injection-as.rst @@ -0,0 +1,4 @@ +- Documented syntax :n:`injection @term as [= {+ @intropattern} ]` as + an alternative to :n:`injection @term as {+ @simple_intropattern}` using + the standard :n:`@injection_intropattern` syntax (`#09288 + <https://github.com/coq/coq/pull/09288>`_, by Hugo Herbelin). diff --git a/doc/changelog/07-commands-and-options/10185-instance-no-bang.rst b/doc/changelog/07-commands-and-options/10185-instance-no-bang.rst new file mode 100644 index 0000000000..c69cda9656 --- /dev/null +++ b/doc/changelog/07-commands-and-options/10185-instance-no-bang.rst @@ -0,0 +1,2 @@ +- Remove undocumented :n:`Instance : !@type` syntax + (`#10185 <https://github.com/coq/coq/pull/10185>`_, by Gaëtan Gilbert). 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/common/styles/html/coqremote/modules/system/system.css b/doc/common/styles/html/coqremote/modules/system/system.css index 9371bb479e..9556c7882a 100644 --- a/doc/common/styles/html/coqremote/modules/system/system.css +++ b/doc/common/styles/html/coqremote/modules/system/system.css @@ -327,7 +327,7 @@ html.js fieldset.collapsed legend a { * html.js fieldset.collapsed table * { display: inline; } -/* For Safari 2 to prevent collapsible fieldsets containing tables from dissapearing due to tableheader.js. */ +/* For Safari 2 to prevent collapsible fieldsets containing tables from disappearing due to tableheader.js. */ html.js fieldset.collapsible { position: relative; } diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 1d0aca1caf..300d62285a 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -94,9 +94,9 @@ VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY { 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 + let sigma = Evd.from_ctx ctx in Feedback.msg_notice - (Printer.pr_econstr_env (Global.env()) evd + (Printer.pr_econstr_env (Global.env()) sigma (Simple_check.simple_check1 v)) } END @@ -104,9 +104,9 @@ 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 + let sigma, ty = Simple_check.simple_check2 v in Feedback.msg_notice - (Printer.pr_econstr_env (Global.env()) evd ty) } + (Printer.pr_econstr_env (Global.env()) sigma ty) } END VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY @@ -114,9 +114,9 @@ VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY { 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 + let sigma = Evd.from_ctx ctx in Feedback.msg_notice - (Printer.pr_econstr_env (Global.env()) evd + (Printer.pr_econstr_env (Global.env()) sigma (Simple_check.simple_check3 v)) } END @@ -128,9 +128,9 @@ END VERNAC COMMAND EXTEND ExamplePrint CLASSIFIED AS QUERY | [ "Cmd8" reference(r) ] -> { let env = Global.env() in - let evd = Evd.from_env env in + let sigma = Evd.from_env env in Feedback.msg_notice - (Printer.pr_econstr_env env evd + (Printer.pr_econstr_env env sigma (EConstr.of_constr (Simple_print.simple_body_access (Nametab.global r)))) } END @@ -145,12 +145,11 @@ END it gives an error message that is basically impossible to understand. *) VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY -| ![ proof ] [ "Cmd9" ] -> +| ![ proof_query ] [ "Cmd9" ] -> { 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/simple_check.ml b/doc/plugin_tutorial/tuto1/src/simple_check.ml index 2949adde73..c2f09c64e0 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_check.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_check.ml @@ -1,32 +1,32 @@ let simple_check1 value_with_constraints = begin let evalue, st = value_with_constraints in - let evd = Evd.from_ctx st in + let sigma = 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 + (EConstr.to_constr sigma 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 + let sigma = 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, 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 (Global.env()) sigma evalue let simple_check3 value_with_constraints = let evalue, st = value_with_constraints in - let evd = Evd.from_ctx st in + let sigma = 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 + Retyping.get_type_of ~lax:true (Global.env()) sigma evalue diff --git a/doc/plugin_tutorial/tuto1/src/simple_print.ml b/doc/plugin_tutorial/tuto1/src/simple_print.ml index cfc38ff9c9..22a0163fbb 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_print.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_print.ml @@ -11,7 +11,7 @@ let simple_body_access gref = failwith "constructors are not covered in this example" | Globnames.ConstRef cst -> let cb = Environ.lookup_constant cst (Global.env()) in - match Global.body_of_constant_body cb with + match Global.body_of_constant_body Library.indirect_accessor cb with | Some(e, _) -> e | None -> failwith "This term has no value" 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 82ba45726e..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 @@ -33,7 +33,7 @@ TACTIC EXTEND collapse_hyps END (* More advanced examples, where automatic proof happens but - no tactic is being called explicitely. The first one uses + no tactic is being called explicitly. The first one uses type classes. *) VERNAC COMMAND EXTEND TriggerClasses CLASSIFIED AS QUERY | [ "Tuto3_3" int(n) ] -> { example_classes n } 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/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index e882ce6e88..b568160356 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -21,10 +21,10 @@ type is considered to be a variable. A variable name cannot occur more than once in a given pattern. It is recommended to start variable names by a lowercase letter. -If a pattern has the form ``(c x)`` where ``c`` is a constructor symbol and x +If a pattern has the form ``c x`` where ``c`` is a constructor symbol and x is a linear vector of (distinct) variables, it is called *simple*: it is the kind of pattern recognized by the basic version of match. On -the opposite, if it is a variable ``x`` or has the form ``(c p)`` with ``p`` not +the opposite, if it is a variable ``x`` or has the form ``c p`` with ``p`` not only made of variables, the pattern is called *nested*. A variable pattern matches any value, and the identifier is bound to @@ -216,7 +216,8 @@ Here is an example: end. -Here is another example using disjunctive subpatterns. +Nested disjunctive patterns are allowed, inside parentheses, with the +notation :n:`({+| @pattern})`, as in: .. coqtop:: in diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index 8a895eb515..3dc8707a34 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -168,7 +168,7 @@ The type-preserving optimizations are controlled by the following |Coq| options: .. cmd:: Extraction NoInline {+ @qualid } - Conversely, the constants mentionned by this command will + Conversely, the constants mentioned by this command will never be inlined during extraction. .. cmd:: Print Extraction Inline diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 847abb33fc..2ea0861e47 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -441,7 +441,7 @@ First class setoids and morphisms The implementation is based on a first-class representation of properties of relations and morphisms as typeclasses. That is, the various combinations of properties on relations and morphisms are -represented as records and instances of theses classes are put in a +represented as records and instances of these classes are put in a hint database. For example, the declaration: .. coqdoc:: @@ -528,7 +528,7 @@ pass additional arguments such as ``using relation``. .. tacv:: setoid_reflexivity setoid_symmetry {? in @ident} setoid_transitivity - setoid_rewrite {? @orientation} @term {? at @occs} {? in @ident} + setoid_rewrite {? @orientation} @term {? at @occurrences} {? in @ident} setoid_replace @term with @term {? using relation @term} {? in @ident} {? by @tactic} :name: setoid_reflexivity; setoid_symmetry; setoid_transitivity; setoid_rewrite; setoid_replace @@ -563,17 +563,18 @@ 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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Add Setoid @A @Aeq @ST as @ident +.. cmd:: Add Setoid @qualid__1 @qualid__2 @qualid__3 as @ident This command for declaring setoids and morphisms is also accepted due to backward compatibility reasons. - Here ``Aeq`` is a congruence relation without parameters, ``A`` is its carrier - and ``ST`` is an object of type (``Setoid_Theory A Aeq``) (i.e. a record + Here :n:`@qualid__2` is a congruence relation without parameters, :n:`@qualid__1` is its carrier + and :n:`@qualid__3` is an object of type (:n:`Setoid_Theory @qualid__1 @qualid__2`) (i.e. a record packing together the reflexivity, symmetry and transitivity lemmas). Notice that the syntax is not completely backward compatible since the identifier was not required. @@ -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. @@ -708,91 +715,65 @@ Definitions The generalized rewriting tactic is based on a set of strategies that can be combined to obtain custom rewriting procedures. Its set of strategies is based on Elan’s rewriting strategies :cite:`Luttik97specificationof`. Rewriting -strategies are applied using the tactic ``rewrite_strat s`` where ``s`` is a +strategies are applied using the tactic :n:`rewrite_strat @strategy` where :token:`strategy` is a strategy expression. Strategies are defined inductively as described by the following grammar: -.. productionlist:: rewriting - s, t, u : `strategy` - : `lemma` - : `lemma_right_to_left` - : `failure` - : `identity` - : `reflexivity` - : `progress` - : `failure_catch` - : `composition` - : `left_biased_choice` - : `iteration_one_or_more` - : `iteration_zero_or_more` - : `one_subterm` - : `all_subterms` - : `innermost_first` - : `outermost_first` - : `bottom_up` - : `top_down` - : `apply_hint` - : `any_of_the_terms` - : `apply_reduction` - : `fold_expression` - -.. productionlist:: rewriting - strategy : ( `s` ) - lemma : `c` - lemma_right_to_left : <- `c` - failure : fail - identity : id - reflexivity : refl - progress : progress `s` - failure_catch : try `s` - composition : `s` ; `u` - left_biased_choice : choice `s` `t` - iteration_one_or_more : repeat `s` - iteration_zero_or_more : any `s` - one_subterm : subterm `s` - all_subterms : subterms `s` - innermost_first : innermost `s` - outermost_first : outermost `s` - bottom_up : bottomup `s` - top_down : topdown `s` - apply_hint : hints `hintdb` - any_of_the_terms : terms (`c`)+ - apply_reduction : eval `redexpr` - fold_expression : fold `c` - +.. productionlist:: coq + strategy : `qualid` (lemma, left to right) + : <- `qualid` (lemma, right to left) + : fail (failure) + : id (identity) + : refl (reflexivity) + : progress `strategy` (progress) + : try `strategy` (try catch) + : `strategy` ; `strategy` (composition) + : choice `strategy` `strategy` (left_biased_choice) + : repeat `strategy` (one or more) + : any `strategy` (zero or more) + : subterm `strategy` (one subterm) + : subterms `strategy` (all subterms) + : innermost `strategy` (innermost first) + : outermost `strategy` (outermost first) + : bottomup `strategy` (bottom-up) + : topdown `strategy` (top-down) + : hints `ident` (apply hints from hint database) + : terms `term` ... `term` (any of the terms) + : eval `redexpr` (apply reduction) + : fold `term` (unify) + : ( `strategy` ) Actually a few of these are defined in term of the others using a primitive fixpoint operator: -.. productionlist:: rewriting - try `s` : choice `s` `id` - any `s` : fix `u`. try (`s` ; `u`) - repeat `s` : `s` ; any `s` - bottomup s : fix `bu`. (choice (progress (subterms bu)) s) ; try bu - topdown s : fix `td`. (choice s (progress (subterms td))) ; try td - innermost s : fix `i`. (choice (subterm i) s) - outermost s : fix `o`. (choice s (subterm o)) +- :n:`try @strategy := choice @strategy id` +- :n:`any @strategy := fix @ident. try (@strategy ; @ident)` +- :n:`repeat @strategy := @strategy; any @strategy` +- :n:`bottomup @strategy := fix @ident. (choice (progress (subterms @ident)) @strategy) ; try @ident` +- :n:`topdown @strategy := fix @ident. (choice @strategy (progress (subterms @ident))) ; try @ident` +- :n:`innermost @strategy := fix @ident. (choice (subterm @ident) @strategy)` +- :n:`outermost @strategy := fix @ident. (choice @strategy (subterm @ident))` The basic control strategy semantics are straightforward: strategies are applied to subterms of the term to rewrite, starting from the root of the term. The lemma strategies unify the left-hand-side of the lemma with the current subterm and on success rewrite it to the right- hand-side. Composition can be used to continue rewriting on the -current subterm. The fail strategy always fails while the identity +current subterm. The ``fail`` strategy always fails while the identity strategy succeeds without making progress. The reflexivity strategy succeeds, making progress using a reflexivity proof of rewriting. -Progress tests progress of the argument strategy and fails if no +``progress`` tests progress of the argument :token:`strategy` and fails if no progress was made, while ``try`` always succeeds, catching failures. -Choice is left-biased: it will launch the first strategy and fall back +``choice`` is left-biased: it will launch the first strategy and fall back on the second one in case of failure. One can iterate a strategy at least 1 time using ``repeat`` and at least 0 times using ``any``. -The ``subterm`` and ``subterms`` strategies apply their argument strategy ``s`` to +The ``subterm`` and ``subterms`` strategies apply their argument :token:`strategy` to respectively one or all subterms of the current term under consideration, left-to-right. ``subterm`` stops at the first subterm for -which ``s`` made progress. The composite strategies ``innermost`` and ``outermost`` +which :token:`strategy` made progress. The composite strategies ``innermost`` and ``outermost`` perform a single innermost or outermost rewrite using their argument -strategy. Their counterparts ``bottomup`` and ``topdown`` perform as many +:token:`strategy`. Their counterparts ``bottomup`` and ``topdown`` perform as many rewritings as possible, starting from the bottom or the top of the term. @@ -802,15 +783,15 @@ lemmas at the current subterm. The ``terms`` strategy takes the lemma names directly as arguments. The ``eval`` strategy expects a reduction expression (see :ref:`performingcomputations`) and succeeds if it reduces the subterm under consideration. The ``fold`` strategy takes -a term ``c`` and tries to *unify* it to the current subterm, converting it to ``c`` -on success, it is stronger than the tactic ``fold``. +a :token:`term` and tries to *unify* it to the current subterm, converting it to :token:`term` +on success. It is stronger than the tactic ``fold``. Usage ~~~~~ -.. tacn:: rewrite_strat @s {? in @ident } +.. tacn:: rewrite_strat @strategy {? in @ident } :name: rewrite_strat Rewrite using the strategy s in hypothesis ident or the conclusion. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 22ddcae584..45c74ab02a 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -299,9 +299,9 @@ optional tactic is replaced by the default one if not specified. Displays all remaining obligations. -.. cmd:: Obligation num {? of @ident} +.. cmd:: Obligation @num {? of @ident} - Start the proof of obligation num. + Start the proof of obligation :token:`num`. .. cmd:: Next Obligation {? of @ident} diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 3b350d5dc0..3f4d5cc784 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -310,10 +310,10 @@ The syntax for adding a new ring is .. productionlist:: coq ring_mod : abstract | decidable `term` | morphism `term` : setoid `term` `term` - : constants [`ltac`] - : preprocess [`ltac`] - : postprocess [`ltac`] - : power_tac `term` [`ltac`] + : constants [ `tactic` ] + : preprocess [ `tactic` ] + : postprocess [ `tactic` ] + : power_tac `term` [ `tactic` ] : sign `term` : div `term` @@ -341,31 +341,31 @@ The syntax for adding a new ring is This modifier needs not be used if the setoid and morphisms have been declared. - constants [ :n:`@ltac` ] - specifies a tactic expression :n:`@ltac` that, given a + constants [ :n:`@tactic` ] + specifies a tactic expression :n:`@tactic` that, given a term, returns either an object of the coefficient set that is mapped to the expression via the morphism, or returns ``InitialRing.NotConstant``. The default behavior is to map only 0 and 1 to their counterpart in the coefficient set. This is generally not desirable for non trivial computational rings. - preprocess [ :n:`@ltac` ] - specifies a tactic :n:`@ltac` that is applied as a + preprocess [ :n:`@tactic` ] + specifies a tactic :n:`@tactic` that is applied as a preliminary step for :tacn:`ring` and :tacn:`ring_simplify`. It can be used to transform a goal so that it is better recognized. For instance, ``S n`` can be changed to ``plus 1 n``. - postprocess [ :n:`@ltac` ] - specifies a tactic :n:`@ltac` that is applied as a final + postprocess [ :n:`@tactic` ] + specifies a tactic :n:`@tactic` that is applied as a final step for :tacn:`ring_simplify`. For instance, it can be used to undo modifications of the preprocessor. - power_tac :n:`@term` [ :n:`@ltac` ] + power_tac :n:`@term` [ :n:`@tactic` ] allows :tacn:`ring` and :tacn:`ring_simplify` to recognize power expressions with a constant positive integer exponent (example: :math:`x^2` ). The term :n:`@term` is a proof that a given power function satisfies the specification of a power function (term has to be a proof of - ``Ring_theory.power_theory``) and :n:`@ltac` specifies a tactic expression + ``Ring_theory.power_theory``) and :n:`@tactic` specifies a tactic expression that, given a term, “abstracts” it into an object of type |N| whose interpretation via ``Cp_phi`` (the evaluation function of power coefficient) is the original term, or returns ``InitialRing.NotConstant`` diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 65934efaa6..2ba13db042 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -385,7 +385,7 @@ few other commands related to typeclasses. .. note:: As of Coq 8.6, ``all:once (typeclasses eauto)`` faithfully - mimicks what happens during typeclass resolution when it is called + mimics what happens during typeclass resolution when it is called during refinement/type inference, except that *only* declared class subgoals are considered at the start of resolution during type inference, while ``all`` can select non-class subgoals as well. It might diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 6b10b7c0b3..395b5ce2d3 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -366,24 +366,32 @@ The syntax has been extended to allow users to explicitly bind names to universes and explicitly instantiate polymorphic definitions. .. cmd:: Universe @ident + Polymorphic Universe @ident In the monorphic case, this command declares a new global universe named :g:`ident`, which can be referred to using its qualified name as well. Global universe names live in a separate namespace. The - command supports the polymorphic flag only in sections, meaning the + command supports the ``Polymorphic`` flag only in sections, meaning the universe quantification will be discharged on each section definition independently. One cannot mix polymorphic and monomorphic declarations in the same section. -.. cmd:: Constraint @ident @ord @ident +.. cmd:: Constraint @universe_constraint + Polymorphic Constraint @universe_constraint - This command declares a new constraint between named universes. The - order relation :n:`@ord` can be one of :math:`<`, :math:`≤` or :math:`=`. If consistent, the constraint - is then enforced in the global environment. Like ``Universe``, it can be - used with the ``Polymorphic`` prefix in sections only to declare - constraints discharged at section closing time. One cannot declare a - global constraint on polymorphic universes. + This command declares a new constraint between named universes. + + .. productionlist:: coq + universe_constraint : `qualid` < `qualid` + : `qualid` <= `qualid` + : `qualid` = `qualid` + + If consistent, the constraint is then enforced in the global + environment. Like :cmd:`Universe`, it can be used with the + ``Polymorphic`` prefix in sections only to declare constraints + discharged at section closing time. One cannot declare a global + constraint on polymorphic universes. .. exn:: Undeclared universe @ident. :undocumented: @@ -449,7 +457,7 @@ underscore or by omitting the annotation to a polymorphic definition. This option, on by default, removes universes which appear only in the body of an opaque polymorphic definition from the definition's universe arguments. As such, no value needs to be provided for - these universes when instanciating the definition. Universe + these universes when instantiating the definition. Universe constraints are automatically adjusted. Consider the following definition: diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index cc2c43e7dd..db4ebd5e38 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -186,7 +186,7 @@ Coq is now continuously tested against OCaml trunk, in addition to the oldest supported and latest OCaml releases. Coq's documentation for the development branch is now deployed -continously at https://coq.github.io/doc/master/api (documentation of +continuously at https://coq.github.io/doc/master/api (documentation of the ML API), https://coq.github.io/doc/master/refman (reference manual), and https://coq.github.io/doc/master/stdlib (documentation of the standard library). Similar links exist for the `v8.10` branch. @@ -656,8 +656,8 @@ changes: attribute. - Removed deprecated commands ``Arguments Scope`` and ``Implicit - Arguments`` in favor of :cmd:`Arguments`, with the help of Jasper - Hugunin. + Arguments`` in favor of :cmd:`Arguments (scopes)` and + :cmd:`Arguments (implicits)`, with the help of Jasper Hugunin. - New flag :flag:`Uniform Inductive Parameters` by Jasper Hugunin to avoid repeating uniform parameters in constructor declarations. @@ -665,7 +665,7 @@ changes: - New commands :cmd:`Hint Variables` and :cmd:`Hint Constants`, by Matthieu Sozeau, for controlling the opacity status of variables and constants in hint databases. It is recommended to always use these - commands after creating a hint databse with :cmd:`Create HintDb`. + commands after creating a hint database with :cmd:`Create HintDb`. - Multiple sections with the same name are now allowed, by Jasper Hugunin. @@ -892,7 +892,7 @@ Vernacular Commands `Inductive list (A : Type) := nil : list | cons : A -> list -> list.` - New `Set Hint Variables/Constants Opaque/Transparent` commands for setting globally the opacity flag of variables and constants in hint databases, - overwritting the opacity set of the hint database. + overwriting the opacity set of the hint database. - Added generic syntax for "attributes", as in: `#[local] Lemma foo : bar.` - Added the `Numeral Notation` command for registering decimal numeral @@ -1129,7 +1129,7 @@ Tactics few rare incompatibilities (it was unintendedly recursively rewriting in the side conditions generated by H). - Added tactics "assert_succeeds tac" and "assert_fails tac" to ensure - properties of the executation of a tactic without keeping the effect + properties of the execution of a tactic without keeping the effect of the execution. - `vm_compute` now supports existential variables. - Calls to `shelve` and `give_up` within calls to tactic `refine` now working. @@ -1262,7 +1262,7 @@ Tools Tactic language - The undocumented "nameless" forms `fix N`, `cofix` have been - deprecated; please use `fix ident N /cofix ident` to explicitely + deprecated; please use `fix ident N /cofix ident` to explicitly name the (co)fixpoint hypothesis to be introduced. Documentation @@ -2953,7 +2953,7 @@ Other bugfixes - Fix incorrect behavior of CS resolution - #4591: Uncaught exception in directory browsing. - CoqIDE is more resilient to initialization errors. -- #4614: "Fully check the document" is uninterruptable. +- #4614: "Fully check the document" is uninterruptible. - Try eta-expansion of records only on non-recursive ones - Fix bug when a sort is ascribed to a Record - Primitive projections: protect kernel from erroneous definitions. @@ -3442,7 +3442,7 @@ Libraries * all functions over type Z : Z.add, Z.mul, ... * the minimal proofs of specifications for these functions : Z.add_0_l, ... - * an instantation of all derived properties proved generically in Numbers : + * an instantiation of all derived properties proved generically in Numbers : Z.add_comm, Z.add_assoc, ... A large part of ZArith is now simply compatibility notations, for instance @@ -4623,7 +4623,7 @@ Setoid rewriting + Setoid_Theory is now an alias to Equivalence, scripts building objects of type Setoid_Theory need to unfold (or "red") the definitions of Reflexive, Symmetric and Transitive in order to get the same goals - as before. Scripts which introduced variables explicitely will not break. + as before. Scripts which introduced variables explicitly will not break. + The order of subgoals when doing [setoid_rewrite] with side-conditions is always the same: first the new goal, then the conditions. @@ -5022,7 +5022,7 @@ Syntax Language and commands -- Added sort-polymorphism for definitions in Type (but finally abandonned). +- Added sort-polymorphism for definitions in Type (but finally abandoned). - Support for implicit arguments in the types of parameters in (co-)fixpoints and (co-)inductive declarations. - Improved type inference: use as much of possible general information. @@ -5251,7 +5251,7 @@ Library - New file about the factorial function in Arith -- An additional elimination Acc_iter for Acc, simplier than Acc_rect. +- An additional elimination Acc_iter for Acc, simpler than Acc_rect. This new elimination principle is used for definition well_founded_induction. - New library NArith on binary natural numbers @@ -5336,7 +5336,7 @@ Bugs Miscellaneous - Implicit parameters of inductive types definition now taken into - account for infering other implicit arguments + account for inferring other implicit arguments Incompatibilities @@ -5417,7 +5417,7 @@ Gallina Known problems of the automatic translation - iso-latin-1 characters are no longer supported: move your files to - 7-bits ASCII or unicode before translation (swith to unicode is + 7-bits ASCII or unicode before translation (switch to unicode is automatically done if a file is loaded and saved again by coqide) - Renaming in ZArith: incompatibilities in Coq user contribs due to merging names INZ, from Reals, and inject_nat. @@ -5442,7 +5442,7 @@ Vernacular commands - "Functional Scheme" and "Functional Induction" extended to polymorphic types and dependent types - Notation now allows recursive patterns, hence recovering parts of the - fonctionalities of pre-V8 Grammar/Syntax commands + functionalities of pre-V8 Grammar/Syntax commands - Command "Print." discontinued. - Redundant syntax "Implicit Arguments On/Off" discontinued diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index ec3343dac6..53309cd313 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -181,7 +181,21 @@ suppress_warnings = ["misc.highlighting_failure"] todo_include_todos = False # Extra warnings, including undefined references -nitpicky = False +nitpicky = True + +nitpick_ignore = [ ('token', token) for token in [ + 'tactic', + # 142 occurrences currently sort of defined in the ltac chapter, + # but is it the right place? + 'module', + 'redexpr', + 'modpath', + 'dirpath', + 'collection', + 'term_pattern', + 'term_pattern_string', + 'command', + 'symbol' ]] # -- Options for HTML output ---------------------------------------------- diff --git a/doc/sphinx/history.rst b/doc/sphinx/history.rst index 0f5b991ba4..c4a48d6985 100644 --- a/doc/sphinx/history.rst +++ b/doc/sphinx/history.rst @@ -110,7 +110,7 @@ advantage of special hardware, debuggers, and the like. We hope that |Coq| can be of use to researchers interested in experimenting with this new methodology. -.. [#years] At the time of writting, i.e. 1995. +.. [#years] At the time of writing, i.e. 1995. Versions 1 to 5 --------------- @@ -305,7 +305,7 @@ Michel Mauny, Ascander Suarez and Pierre Weis. V3.1 was started in the summer of 1986, V3.2 was frozen at the end of November 1986. V3.4 was developed in the first half of 1987. -Thierry Coquand held a post-doctoral position in Cambrige University +Thierry Coquand held a post-doctoral position in Cambridge University in 1986-87, where he developed a variant implementation in SML, with which he wrote some developments on fixpoints in Scott's domains. @@ -345,7 +345,7 @@ lemmas when local hypotheses of proofs were discharged. This gave a notion of global mathematical environment with local sections. Another significant practical change was that the system, originally -developped on the VAX central computer of our lab, was transferred on +developed on the VAX central computer of our lab, was transferred on SUN personal workstations, allowing a level of distributed development. The extraction algorithm was modified, with three annotations ``Pos``, ``Null`` and ``Typ`` decorating the sorts ``Prop`` @@ -503,7 +503,7 @@ of CNRS-ENS Lyon. Chetan Murthy joined the team in 1991 and became the main software architect of Version 5. He completely rehauled the implementation for efficiency. Versions 5.6 and 5.8 were major distributed versions, -with complete documentation and a library of users' developements. The +with complete documentation and a library of users' developments. The use of the RCS revision control system, and systematic ChangeLog files, allow a more precise tracking of the software developments. @@ -1330,7 +1330,7 @@ Language - Inductive definitions now accept ">" in constructor types to declare the corresponding constructor as a coercion. -- Idem for assumptions declarations and constants when the type is mentionned. +- Idem for assumptions declarations and constants when the type is mentioned. - The "Coercion" and "Canonical Structure" keywords now accept the same syntax as "Definition", i.e. "hyps :=c (:t)?" or "hyps :t". - Theorem-like declaration now accepts the syntax "Theorem thm [x:t;...] : u". @@ -1383,7 +1383,7 @@ Tactics it can also recognize 'False' in the hypothesis and use it to solve the goal. - Coercions now handled in "with" bindings -- "Subst x" replaces all ocurrences of x by t in the goal and hypotheses +- "Subst x" replaces all occurrences of x by t in the goal and hypotheses when an hypothesis x=t or x:=t or t=x exists - Fresh names for Assert and Pose now based on collision-avoiding Intro naming strategy (exceptional source of incompatibilities) diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 5e214f6f7f..c93984661e 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -603,11 +603,16 @@ The following experimental command is available when the ``FunInd`` library has The meaning of this declaration is to define a function ident, similarly to ``Fixpoint``. Like in ``Fixpoint``, the decreasing argument must be given (unless the function is not recursive), but it might not - necessarily be *structurally* decreasing. The point of the {} annotation + necessarily be *structurally* decreasing. The point of the :n:`{ @decrease_annot }` annotation is to name the decreasing argument *and* to describe which kind of decreasing criteria must be used to ensure termination of recursive calls. + .. productionlist:: + decrease_annot : struct `ident` + : measure `term` `ident` + : wf `term` `ident` + The ``Function`` construction also enjoys the ``with`` extension to define mutually recursive definitions. However, this feature does not work for non structurally recursive functions. @@ -616,31 +621,33 @@ See the documentation of functional induction (:tacn:`function induction`) and ``Functional Scheme`` (:ref:`functional-scheme`) for how to use the induction principle to easily reason about the function. -Remark: To obtain the right principle, it is better to put rigid -parameters of the function as first arguments. For example it is -better to define plus like this: +.. note:: -.. coqtop:: reset none + To obtain the right principle, it is better to put rigid + parameters of the function as first arguments. For example it is + better to define plus like this: - Require Import FunInd. + .. coqtop:: reset none -.. coqtop:: all + Require Import FunInd. - Function plus (m n : nat) {struct n} : nat := - match n with - | 0 => m - | S p => S (plus m p) - end. + .. coqtop:: all -than like this: + Function plus (m n : nat) {struct n} : nat := + match n with + | 0 => m + | S p => S (plus m p) + end. -.. coqtop:: reset all + than like this: - Function plus (n m : nat) {struct n} : nat := - match n with - | 0 => m - | S p => S (plus p m) - end. + .. coqtop:: reset all + + Function plus (n m : nat) {struct n} : nat := + match n with + | 0 => m + | S p => S (plus p m) + end. *Limitations* @@ -710,7 +717,7 @@ used by ``Function``. A more precise description is given below. with :cmd:`Fixpoint`. Moreover the following are defined: + The same objects as above; - + The fixpoint equation of :token:`ident`: :n:`@ident_equation`. + + The fixpoint equation of :token:`ident`: :token:`ident`\ ``_equation``. .. cmdv:: Function @ident {* @binder } { measure @term @ident } : @type := @term Function @ident {* @binder } { wf @term @ident } : @type := @term @@ -730,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 @@ -1662,6 +1669,7 @@ Declaring Implicit Arguments of :token:`qualid`. .. cmd:: Arguments @qualid : clear implicits + :name: Arguments (clear implicits) This command clears implicit arguments. @@ -1738,6 +1746,7 @@ Automatic declaration of implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. cmd:: Arguments @qualid : default implicits + :name: Arguments (default implicits) This command tells |Coq| to automatically detect what are the implicit arguments of a defined object. @@ -1907,7 +1916,8 @@ This syntax extension is given in the following grammar: Renaming implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Arguments @qualid {* @name} : @rename +.. cmd:: Arguments @qualid {* @name} : rename + :name: Arguments (rename) This command is used to redefine the names of implicit arguments. @@ -2131,24 +2141,71 @@ Implicit generalization .. index:: `{ } .. index:: `( ) +.. index:: `{! } +.. index:: `(! ) Implicit generalization is an automatic elaboration of a statement with free variables into a closed statement where these variables are -quantified explicitly. Implicit generalization is done inside binders -starting with a \` and terms delimited by \`{ } and \`( ), always -introducing maximally inserted implicit arguments for the generalized -variables. Inside implicit generalization delimiters, free variables -in the current context are automatically quantified using a product or -a lambda abstraction to generate a closed term. In the following -statement for example, the variables n and m are automatically -generalized and become explicit arguments of the lemma as we are using -\`( ): +quantified explicitly. -.. coqtop:: all +It is activated for a binder by prefixing a \`, and for terms by +surrounding it with \`{ } or \`( ). + +Terms surrounded by \`{ } introduce their free variables as maximally +inserted implicit arguments, and terms surrounded by \`( ) introduce +them as explicit arguments. + +Generalizing binders always introduce their free variables as +maximally inserted implicit arguments. The binder itself introduces +its argument as usual. + +In the following statement, ``A`` and ``y`` are automatically +generalized, ``A`` is implicit and ``x``, ``y`` and the anonymous +equality argument are explicit. + +.. coqtop:: all reset Generalizable All Variables. - Lemma nat_comm : `(n = n + 0). + Definition sym `(x:A) : `(x = y -> y = x) := fun _ p => eq_sym p. + + Print sym. + +Dually to normal binders, the name is optional but the type is required: + +.. coqtop:: all + + Check (forall `{x = y :> A}, y = x). + +When generalizing a binder whose type is a typeclass, its own class +arguments are omitted from the syntax and are generalized using +automatic names, without instance search. Other arguments are also +generalized unless provided. This produces a fully general statement. +this behaviour may be disabled by prefixing the type with a ``!`` or +by forcing the typeclass name to be an explicit application using +``@`` (however the later ignores implicit argument information). + +.. coqtop:: all + + Class Op (A:Type) := op : A -> A -> A. + + Class Commutative (A:Type) `(Op A) := commutative : forall x y, op x y = op y x. + Instance nat_op : Op nat := plus. + + Set Printing Implicit. + Check (forall `{Commutative }, True). + Check (forall `{Commutative nat}, True). + Fail Check (forall `{Commutative nat _}, True). + Fail Check (forall `{!Commutative nat}, True). + Arguments Commutative _ {_}. + Check (forall `{!Commutative nat}, True). + Check (forall `{@Commutative nat plus}, True). + +Multiple binders can be merged using ``,`` as a separator: + +.. coqtop:: all + + Check (forall `{Commutative A, Hnat : !Commutative nat}, True). One can control the set of generalizable identifiers with the ``Generalizable`` vernacular command to avoid unexpected @@ -2176,22 +2233,6 @@ that specify which variables should be generalizable. Allows exporting the choice of generalizable variables. -One can also use implicit generalization for binders, in which case -the generalized variables are added as binders and set maximally -implicit. - -.. coqtop:: all - - Definition id `(x : A) : A := x. - - Print id. - -The generalizing binders \`{ } and \`( ) work similarly to their -explicit counterparts, only binding the generalized variables -implicitly, as maximally-inserted arguments. In these binders, the -binding name for the bound object is optional, whereas the type is -mandatory, dually to regular binders. - .. _Coercions: Coercions @@ -2262,7 +2303,7 @@ Printing universes language, and can be processed by Graphviz tools. The format is unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. -.. cmdv:: Print Universes Subgraph(@names) +.. cmdv:: Print Universes Subgraph({+ @qualid }) :name: Print Universes Subgraph Prints the graph restricted to the requested names (adjusting @@ -2407,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/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 8acbcbec8f..ebaa6fde66 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -185,8 +185,7 @@ is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. : `qualid` : _ : `num` - : ( `or_pattern` , … , `or_pattern` ) - or_pattern : `pattern` | … | `pattern` + : ( `pattern` | … | `pattern` ) Types diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index bbd7e0ba3d..c48dd5b99e 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -32,22 +32,25 @@ The syntax of the tactic language is given below. See Chapter :ref:`gallinaspecificationlanguage` for a description of the BNF metasyntax used in these grammar rules. Various already defined entries will be used in this chapter: entries :token:`natural`, :token:`integer`, :token:`ident`, -:token:`qualid`, :token:`term`, :token:`cpattern` and :token:`atomic_tactic` +:token:`qualid`, :token:`term`, :token:`cpattern` and :token:`tactic` represent respectively the natural and integer numbers, the authorized identificators and qualified names, Coq terms and patterns and all the atomic -tactics described in Chapter :ref:`tactics`. The syntax of :token:`cpattern` is +tactics described in Chapter :ref:`tactics`. + +The syntax of :production:`cpattern` is the same as that of terms, but it is extended with pattern matching metavariables. In :token:`cpattern`, a pattern matching metavariable is -represented with the syntax :g:`?id` where :g:`id` is an :token:`ident`. The +represented with the syntax :n:`?@ident`. The notation :g:`_` can also be used to denote metavariable whose instance is -irrelevant. In the notation :g:`?id`, the identifier allows us to keep +irrelevant. In the notation :n:`?@ident`, the identifier allows us to keep instantiations and to make constraints whereas :g:`_` shows that we are not interested in what will be matched. On the right hand side of pattern matching clauses, the named metavariables are used without the question mark prefix. There is also a special notation for second-order pattern matching problems: in an -applicative pattern of the form :g:`@?id id1 … idn`, the variable id matches any -complex expression with (possible) dependencies in the variables :g:`id1 … idn` -and returns a functional term of the form :g:`fun id1 … idn => term`. +applicative pattern of the form :n:`%@?@ident @ident__1 … @ident__n`, +the variable :token:`ident` matches any complex expression with (possible) +dependencies in the variables :n:`@ident__i` and returns a functional term +of the form :n:`fun @ident__1 … ident__n => @term`. The main entry of the grammar is :n:`@expr`. This language is used in proof mode but it can also be used in toplevel definitions as shown below. @@ -121,6 +124,7 @@ mode but it can also be used in toplevel definitions as shown below. : solve [ `expr` | ... | `expr` ] : idtac [ `message_token` ... `message_token`] : fail [`natural`] [`message_token` ... `message_token`] + : gfail [`natural`] [`message_token` ... `message_token`] : fresh [ `component` … `component` ] : context `ident` [`term`] : eval `redexpr` in `term` @@ -132,7 +136,7 @@ mode but it can also be used in toplevel definitions as shown below. : guard `test` : assert_fails `tacexpr3` : assert_succeeds `tacexpr3` - : `atomic_tactic` + : `tactic` : `qualid` `tacarg` ... `tacarg` : `atom` atom : `qualid` @@ -582,11 +586,11 @@ Failing the call to :n:`fail @num` is not enclosed in a :n:`+` command, respecting the algebraic identity. - .. tacv:: fail {* message_token} + .. tacv:: fail {* @message_token} The given tokens are used for printing the failure message. - .. tacv:: fail @num {* message_token} + .. tacv:: fail @num {* @message_token} This is a combination of the previous variants. @@ -597,8 +601,8 @@ Failing Similarly, ``gfail`` fails even when used after ``all:`` and there are no goals left. See the example for clarification. - .. tacv:: gfail {* message_token} - gfail @num {* message_token} + .. tacv:: gfail {* @message_token} + gfail @num {* @message_token} These variants fail with an error message or an error level even if there are no goals left. Be careful however if Coq terms have to be @@ -708,7 +712,7 @@ tactic for printing. By copying the definition of :tacn:`time_constr` from the standard library, - users can achive support for a fixed pattern of nesting by passing + users can achieve support for a fixed pattern of nesting by passing different :token:`string` parameters to :tacn:`restart_timer` and :tacn:`finish_timing` at each level of nesting. @@ -964,7 +968,7 @@ system decide a name with the intro tactic is not so good since it is very awkward to retrieve the name the system gave. The following expression returns an identifier: -.. tacn:: fresh {* component} +.. tacn:: fresh {* @component} It evaluates to an identifier unbound in the goal. This fresh identifier is obtained by concatenating the value of the :n:`@component`\ s (each of them @@ -1676,7 +1680,7 @@ It is possible to measure the time spent in invocations of primitive tactics as well as tactics defined in |Ltac| and their inner invocations. The primary use is the development of complex tactics, which can sometimes be so slow as to impede interactive usage. The -reasons for the performence degradation can be intricate, like a slowly +reasons for the performance degradation can be intricate, like a slowly performing |Ltac| match or a sub-tactic whose performance only degrades in certain situations. The profiler generates a call tree and indicates the time spent in a tactic depending on its calling context. Thus diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index aa603fc966..5f2e911ff9 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -124,13 +124,13 @@ Type declarations One can define new types by the following commands. -.. cmd:: Ltac2 Type @ltac2_typeparams @lident +.. cmd:: Ltac2 Type {? @ltac2_typeparams } @lident :name: Ltac2 Type This command defines an abstract type. It has no use for the end user and is dedicated to types representing data coming from the OCaml world. -.. cmdv:: Ltac2 Type {? rec} @ltac2_typeparams @lident := @ltac2_typedef +.. cmdv:: Ltac2 Type {? rec} {? @ltac2_typeparams } @lident := @ltac2_typedef This command defines a type with a manifest. There are four possible kinds of such definitions: alias, variant, record and open variant types. @@ -154,7 +154,7 @@ One can define new types by the following commands. Records are product types with named fields and eliminated by projection. Likewise they can be recursive if the `rec` flag is set. - .. cmdv:: Ltac2 Type @ltac2_typeparams @ltac2_qualid := [ @ltac2_constructordef ] + .. cmdv:: Ltac2 Type {? @ltac2_typeparams } @ltac2_qualid ::= [ @ltac2_constructordef ] Open variants are a special kind of variant types whose constructors are not statically defined, but can instead be extended dynamically. A typical example @@ -179,7 +179,7 @@ constructions from ML. : let `ltac2_var` := `ltac2_term` in `ltac2_term` : let rec `ltac2_var` := `ltac2_term` in `ltac2_term` : match `ltac2_term` with `ltac2_branch` ... `ltac2_branch` end - : `int` + : `integer` : `string` : `ltac2_term` ; `ltac2_term` : [| `ltac2_term` ; ... ; `ltac2_term` |] @@ -619,7 +619,7 @@ calls to term matching functions from the `Pattern` module. Internally, it is implemented thanks to a specific scope accepting the :n:`@constrmatching` syntax. Variables from the :n:`@constrpattern` are statically bound in the body of the branch, to -values of type `constr` for the variables from the :n:`@constr` pattern and to a +values of type `constr` for the variables from the :n:`@term` pattern and to a value of type `Pattern.context` for the variable :n:`@lident`. Note that unlike Ltac, only lowercase identifiers are valid as Ltac2 @@ -686,20 +686,22 @@ The following scopes are built-in. - :n:`list0(@ltac2_scope)`: - + if :n:`@ltac2_scope` parses :production:`entry`, parses :n:`(@entry__0, ..., @entry__n)` and produces - :n:`[@entry__0; ...; @entry__n]`. + + if :n:`@ltac2_scope` parses :n:`@quotentry`, + then it parses :n:`(@quotentry__0, ..., @quotentry__n)` and produces + :n:`[@quotentry__0; ...; @quotentry__n]`. - :n:`list0(@ltac2_scope, sep = @string__sep)`: - + if :n:`@ltac2_scope` parses :n:`@entry`, parses :n:`(@entry__0 @string__sep ... @string__sep @entry__n)` - and produces :n:`[@entry__0; ...; @entry__n]`. + + if :n:`@ltac2_scope` parses :n:`@quotentry`, + then it parses :n:`(@quotentry__0 @string__sep ... @string__sep @quotentry__n)` + and produce :n:`[@quotentry__0; ...; @quotentry__n]`. -- :n:`list1`: same as :n:`list0` (with or without separator) but parses :n:`{+ @entry}` instead - of :n:`{* @entry}`. +- :n:`list1`: same as :n:`list0` (with or without separator) but parses :n:`{+ @quotentry}` instead + of :n:`{* @quotentry}`. - :n:`opt(@ltac2_scope)` - + if :n:`@ltac2_scope` parses :n:`@entry`, parses :n:`{? @entry}` and produces either :n:`None` or + + if :n:`@ltac2_scope` parses :n:`@quotentry`, parses :n:`{? @quotentry}` and produces either :n:`None` or :n:`Some x` where :n:`x` is the parsed expression. - :n:`self`: diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 4a2f9c0db3..0cff987a27 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -175,12 +175,12 @@ list of assertion commands is given in :ref:`Assertions`. The command Use all section variables except the list of :token:`ident`. - .. cmdv:: Proof using @collection1 + @collection2 + .. cmdv:: Proof using @collection__1 + @collection__2 Use section variables from the union of both collections. See :ref:`nameaset` to know how to form a named collection. - .. cmdv:: Proof using @collection1 - @collection2 + .. cmdv:: Proof using @collection__1 - @collection__2 Use section variables which are in the first collection but not in the second one. @@ -202,10 +202,10 @@ Proof using options The following options modify the behavior of ``Proof using``. -.. opt:: Default Proof Using "@expression" +.. opt:: Default Proof Using "@collection" :name: Default Proof Using - Use :n:`@expression` as the default ``Proof using`` value. E.g. ``Set Default + Use :n:`@collection` as the default ``Proof using`` value. E.g. ``Set Default Proof Using "a b"`` will complete all ``Proof`` commands not followed by a ``using`` part with ``using a b``. @@ -220,7 +220,7 @@ The following options modify the behavior of ``Proof using``. Name a set of section hypotheses for ``Proof using`` ```````````````````````````````````````````````````` -.. cmd:: Collection @ident := @expression +.. cmd:: Collection @ident := @collection This can be used to name a set of section hypotheses, with the purpose of making ``Proof using`` annotations more @@ -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/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 75e019592f..cc4976587d 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -455,7 +455,7 @@ the latter can be replaced by the open syntax ``of term`` or following extension of the binder syntax: .. prodn:: - binder += & @term | of @term + binder += {| & @term | of @term } Caveat: ``& T`` and ``of T`` abbreviations have to appear at the end of a binder list. For instance, the usual two-constructor polymorphic @@ -853,7 +853,7 @@ An *occurrence switch* can be: algorithm in a local definition, instead of copying large terms by hand. -It is important to remember that matching *preceeds* occurrence +It is important to remember that matching *precedes* occurrence selection. .. example:: @@ -1340,7 +1340,7 @@ The general syntax of the discharging tactical ``:`` is: :undocumented: .. prodn:: - d_item ::= {? @occ_switch %| @clear_switch } @term + d_item ::= {? {| @occ_switch | @clear_switch } } @term .. prodn:: clear_switch ::= { {+ @ident } } @@ -1499,7 +1499,7 @@ side of an equation. The abstract tactic ``````````````````` -.. tacn:: abstract: {+ d_item} +.. tacn:: abstract: {+ @d_item} :name: abstract (ssreflect) This tactic assigns an abstract constant previously introduced with the @@ -1556,19 +1556,19 @@ whose general syntax is :undocumented: .. prodn:: - i_item ::= @i_pattern %| @s_item %| @clear_switch %| @i_view %| @i_block + i_item ::= {| @i_pattern | @s_item | @clear_switch | @i_view | @i_block } .. prodn:: - s_item ::= /= %| // %| //= + s_item ::= {| /= | // | //= } .. prodn:: - i_view ::= {? %{%} } /@term %| /ltac:( @tactic ) + i_view ::= {? %{%} } {| /@term | /ltac:( @tactic ) } .. prodn:: - i_pattern ::= @ident %| > %| _ %| ? %| * %| + %| {? @occ_switch } -> %| {? @occ_switch }<- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] + i_pattern ::= {| @ident | > | _ | ? | * | + | {? @occ_switch } {| -> | <- } | [ {?| @i_item } ] | - | [: {+ @ident } ] } .. prodn:: - i_block ::= [^ @ident ] %| [^~ @ident ] %| [^~ @num ] + i_block ::= {| [^ @ident ] | [^~ {| @ident | @num } ] } The ``=>`` tactical first executes :token:`tactic`, then the :token:`i_item`\s, left to right. An :token:`s_item` specifies a @@ -2390,7 +2390,7 @@ of a local definition during the generalization phase, the name of the local definition must be written between parentheses, like in ``rewrite H in H1 (def_n) H2.`` -.. tacv:: @tactic in {+ @clear_switch | {? @ } @ident | ( @ident ) | ( {? @ } @ident := @c_pattern ) } {? * } +.. tacv:: @tactic in {+ {| @clear_switch | {? @}@ident | ( @ident ) | ( {? @}@ident := @c_pattern ) } } {? * } This is the most general form of the ``in`` tactical. In its simplest form the last option lets one rename hypotheses that @@ -2455,7 +2455,7 @@ the holes are abstracted in term. Lemma test : True. have: _ * 0 = 0. - The invokation of ``have`` is equivalent to: + The invocation of ``have`` is equivalent to: .. coqtop:: reset none @@ -2492,7 +2492,7 @@ tactic: The behavior of the defective have tactic makes it possible to generalize it in the following general construction: -.. tacn:: have {* @i_item } {? @i_pattern } {? @s_item | {+ @ssr_binder } } {? : @term } {? := @term | by @tactic } +.. tacn:: have {* @i_item } {? @i_pattern } {? {| @s_item | {+ @ssr_binder } } } {? : @term } {? {| := @term | by @tactic } } :undocumented: Open syntax is supported for both :token:`term`. For the description @@ -2920,7 +2920,7 @@ Advanced generalization The complete syntax for the items on the left hand side of the ``/`` separator is the following one: -.. tacv:: wlog … : {? @clear_switch | {? @ } @ident | ( {? @ } @ident := @c_pattern) } / @term +.. tacv:: wlog … : {? {| @clear_switch | {? @}@ident | ( {? @}@ident := @c_pattern) } } / @term :undocumented: Clear operations are intertwined with generalization operations. This @@ -3020,13 +3020,13 @@ A rewrite step :token:`rstep` has the general form: rstep ::= {? @r_prefix } @r_item .. prodn:: - r_prefix ::= {? - } {? @mult } {? @occ_switch %| @clear_switch } {? [ @r_pattern ] } + r_prefix ::= {? - } {? @mult } {? {| @occ_switch | @clear_switch } } {? [ @r_pattern ] } .. prodn:: - r_pattern ::= @term %| in {? @ident in } @term %| %( @term in %| @term as %) @ident in @term + r_pattern ::= {| @term | in {? @ident in } @term | {| @term in | @term as } @ident in @term } .. prodn:: - r_item ::= {? / } @term %| @s_item + r_item ::= {| {? / } @term | @s_item } An :token:`r_prefix` contains annotations to qualify where and how the rewrite operation should be performed: @@ -3478,7 +3478,7 @@ efficient ones, e.g. for the purpose of a correctness proof. Wildcards vs abstractions ````````````````````````` -The rewrite tactic supports :token:`r_items` containing holes. For example, in +The rewrite tactic supports :token:`r_item`\s containing holes. For example, in the tactic ``rewrite (_ : _ * 0 = 0).`` the term ``_ * 0 = 0`` is interpreted as ``forall n : nat, n * 0 = 0.`` Anyway this tactic is *not* equivalent to @@ -3702,7 +3702,7 @@ The under tactic The convenience :tacn:`under` tactic supports the following syntax: -.. tacn:: under {? @r_prefix } @term {? => {+ @i_item}} {? do ( @tactic | [ {*| @tactic } ] ) } +.. tacn:: under {? @r_prefix } @term {? => {+ @i_item}} {? do {| @tactic | [ {*| @tactic } ] } } :name: under Operate under the context proved to be extensional by @@ -3753,7 +3753,7 @@ involves the following steps: 3. If so :tacn:`under` puts these n goals in head normal form (using the defective form of the tactic :tacn:`move`), then executes - the corresponding intro pattern :n:`@ipat__i` in each goal. + the corresponding intro pattern :n:`@i_pattern__i` in each goal. 4. Then :tacn:`under` checks that the first n subgoals are (quantified) equalities or double implications between a @@ -3802,11 +3802,11 @@ One-liner mode The Ltac expression: -:n:`under @term => [ @i_item__1 | … | @i_item__n ] do [ @tac__1 | … | @tac__n ].` +:n:`under @term => [ @i_item__1 | … | @i_item__n ] do [ @tactic__1 | … | @tactic__n ].` can be seen as a shorter form for the following expression: -:n:`(under @term) => [ @i_item__1 | … | @i_item__n | ]; [ @tac__1; over | … | @tac__n; over | cbv beta iota ].` +:n:`(under @term) => [ @i_item__1 | … | @i_item__n | ]; [ @tactic__1; over | … | @tactic__n; over | cbv beta iota ].` Notes: @@ -3819,14 +3819,14 @@ Notes: involving the `bigop` theory from the Mathematical Components library. + If there is only one tactic, the brackets can be omitted, e.g.: - :n:`under @term => i do @tac.` and that shorter form should be + :n:`under @term => i do @tactic.` and that shorter form should be preferred. + If the ``do`` clause is provided and the intro pattern is omitted, then the default :token:`i_item` ``*`` is applied to each branch. E.g., the Ltac expression: - :n:`under @term do [ @tac__1 | … | @tac__n ]` is equivalent to: - :n:`under @term => [ * | … | * ] do [ @tac__1 | … | @tac__n ]` + :n:`under @term do [ @tactic__1 | … | @tactic__n ]` is equivalent to: + :n:`under @term => [ * | … | * ] do [ @tactic__1 | … | @tactic__n ]` (and it can be noted here that the :tacn:`under` tactic performs a ``move.`` before processing the intro patterns ``=> [ * | … | * ]``). @@ -4237,7 +4237,7 @@ selecting a specific redex and has been described in the previous sections. We have seen so far that the possibility of selecting a redex using a term with holes is already a powerful means of redex selection. Similarly, any terms provided by the user in the more -complex forms of :token:`c_patterns` +complex forms of :token:`c_pattern`\s presented in the tables above can contain holes. @@ -4927,7 +4927,7 @@ bookkeeping steps. apply/PQequiv. thus in this case, the tactic ``apply/PQequiv`` is equivalent to - ``apply: (iffRL (PQequiv _ _))``, where ``iffRL`` is tha analogue of + ``apply: (iffRL (PQequiv _ _))``, where ``iffRL`` is the analogue of ``iffRL`` for the converse implication. Any |SSR| term whose type coerces to a double implication can be @@ -5167,7 +5167,7 @@ Interpreting assumptions The general form of an assumption view tactic is: -.. tacv:: [move | case] / @term +.. tacv:: {| move | case } / @term :undocumented: The term , called the *view lemma* can be: @@ -5514,7 +5514,7 @@ Parameters |SSR| tactics .. prodn:: - d_tactic ::= elim %| case %| congr %| apply %| exact %| move + d_tactic ::= {| elim | case | congr | apply | exact | move } Notation scope @@ -5526,7 +5526,7 @@ Module name Natural number -.. prodn:: natural ::= @num %| @ident +.. prodn:: natural ::= {| @num | @ident } where :token:`ident` is an Ltac variable denoting a standard |Coq| numeral (should not be the name of a tactic which can be followed by a @@ -5535,7 +5535,7 @@ bracket ``[``, like ``do``, ``have``,…) Items and switches ~~~~~~~~~~~~~~~~~~ -.. prodn:: ssr_binder ::= @ident %| ( @ident {? : @term } ) +.. prodn:: ssr_binder ::= {| @ident | ( @ident {? : @term } ) } binder see :ref:`abbreviations_ssr`. @@ -5543,33 +5543,33 @@ binder see :ref:`abbreviations_ssr`. clear switch see :ref:`discharge_ssr` -.. prodn:: c_pattern ::= {? @term in %| @term as } @ident in @term +.. prodn:: c_pattern ::= {? {| @term in | @term as } } @ident in @term context pattern see :ref:`contextual_patterns_ssr` -.. prodn:: d_item ::= {? @occ_switch %| @clear_switch } {? @term %| ( @c_pattern ) } +.. prodn:: d_item ::= {? {| @occ_switch | @clear_switch } } {? {| @term | ( @c_pattern ) } } discharge item see :ref:`discharge_ssr` -.. prodn:: gen_item ::= {? @ } @ident %| ( @ident ) %| ( {? @ } @ident := @c_pattern ) +.. prodn:: gen_item ::= {| {? @ } @ident | ( @ident ) | ( {? @ } @ident := @c_pattern ) } generalization item see :ref:`structure_ssr` -.. prodn:: i_pattern ::= @ident %| > %| _ %| ? %| * %| + %| {? @occ_switch } -> %| {? @occ_switch } <- %| [ {?| @i_item } ] %| - %| [: {+ @ident } ] +.. prodn:: i_pattern ::= {| @ident | > | _ | ? | * | + | {? @occ_switch } {| -> | <- } | [ {?| @i_item } ] | - | [: {+ @ident } ] } intro pattern :ref:`introduction_ssr` -.. prodn:: i_item ::= @clear_switch %| @s_item %| @i_pattern %| @i_view %| @i_block +.. prodn:: i_item ::= {| @clear_switch | @s_item | @i_pattern | @i_view | @i_block } view :ref:`introduction_ssr` .. prodn:: - i_view ::= {? %{%} } /@term %| /ltac:( @tactic ) + i_view ::= {? %{%} } {| /@term | /ltac:( @tactic ) } intro block :ref:`introduction_ssr` .. prodn:: - i_block ::= [^ @ident ] %| [^~ @ident ] %| [^~ @num ] + i_block ::= {| [^ @ident ] | [^~ {| @ident | @num } ] } intro item see :ref:`introduction_ssr` @@ -5577,7 +5577,7 @@ intro item see :ref:`introduction_ssr` multiplier see :ref:`iteration_ssr` -.. prodn:: occ_switch ::= { {? + %| - } {* @num } } +.. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } occur. switch see :ref:`occurrence_selection_ssr` @@ -5585,19 +5585,19 @@ occur. switch see :ref:`occurrence_selection_ssr` multiplier see :ref:`iteration_ssr` -.. prodn:: mult_mark ::= ? %| ! +.. prodn:: mult_mark ::= {| ? | ! } multiplier mark see :ref:`iteration_ssr` -.. prodn:: r_item ::= {? / } @term %| @s_item +.. prodn:: r_item ::= {| {? / } @term | @s_item } rewrite item see :ref:`rewriting_ssr` -.. prodn:: r_prefix ::= {? - } {? @int_mult } {? @occ_switch %| @clear_switch } {? [ @r_pattern ] } +.. prodn:: r_prefix ::= {? - } {? @int_mult } {? {| @occ_switch | @clear_switch } } {? [ @r_pattern ] } rewrite prefix see :ref:`rewriting_ssr` -.. prodn:: r_pattern ::= @term %| @c_pattern %| in {? @ident in } @term +.. prodn:: r_pattern ::= {| @term | @c_pattern | in {? @ident in } @term } rewrite pattern see :ref:`rewriting_ssr` @@ -5605,7 +5605,7 @@ rewrite pattern see :ref:`rewriting_ssr` rewrite step see :ref:`rewriting_ssr` -.. prodn:: s_item ::= /= %| // %| //= +.. prodn:: s_item ::= {| /= | // | //= } simplify switch see :ref:`introduction_ssr` @@ -5640,7 +5640,7 @@ respectively. rewrite (see :ref:`rewriting_ssr`) -.. tacn:: under {? @r_prefix } @term {? => {+ @i_item}} {? do ( @tactic | [ {*| @tactic } ] )} +.. tacn:: under {? @r_prefix } @term {? => {+ @i_item}} {? do {| @tactic | [ {*| @tactic } ] } } under (see :ref:`under_ssr`) @@ -5648,8 +5648,8 @@ respectively. over (see :ref:`over_ssr`) -.. tacn:: have {* @i_item } {? @i_pattern } {? @s_item %| {+ @ssr_binder } } {? : @term } := @term - have {* @i_item } {? @i_pattern } {? @s_item %| {+ @ssr_binder } } : @term {? by @tactic } +.. tacn:: have {* @i_item } {? @i_pattern } {? {| @s_item | {+ @ssr_binder } } } {? : @term } := @term + have {* @i_item } {? @i_pattern } {? {| @s_item | {+ @ssr_binder } } } : @term {? by @tactic } have suff {? @clear_switch } {? @i_pattern } {? : @term } := @term have suff {? @clear_switch } {? @i_pattern } : @term {? by @tactic } gen have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } @@ -5658,7 +5658,7 @@ respectively. forward chaining (see :ref:`structure_ssr`) -.. tacn:: wlog {? suff } {? @i_item } : {* @gen_item %| @clear_switch } / @term +.. tacn:: wlog {? suff } {? @i_item } : {* {| @gen_item | @clear_switch } } / @term specializing (see :ref:`structure_ssr`) @@ -5710,7 +5710,7 @@ discharge :ref:`discharge_ssr` introduction see :ref:`introduction_ssr` -.. prodn:: tactic += @tactic in {+ @gen_item %| @clear_switch } {? * } +.. prodn:: tactic += @tactic in {+ {| @gen_item | @clear_switch } } {? * } localization see :ref:`localization_ssr` diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 4e47621938..fa6d62ffa2 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -131,16 +131,17 @@ include :tacn:`assert`, :tacn:`intros` and :tacn:`destruct`. simple_intropattern_closed : `naming_intropattern` : _ : `or_and_intropattern` - : `equality_intropattern` + : `rewriting_intropattern` + : `injection_intropattern` naming_intropattern : `ident` : ? : ?`ident` or_and_intropattern : [ `intropattern_list` | ... | `intropattern_list` ] : ( `simple_intropattern` , ... , `simple_intropattern` ) : ( `simple_intropattern` & ... & `simple_intropattern` ) - equality_intropattern : -> + rewriting_intropattern : -> : <- - : [= `intropattern_list` ] + injection_intropattern : [= `intropattern_list` ] or_and_intropattern_loc : `or_and_intropattern` : `ident` @@ -462,7 +463,7 @@ Occurrence sets and occurrence clauses An occurrence clause is a modifier to some tactics that obeys the following syntax: - .. productionlist:: sentence + .. productionlist:: coq occurrence_clause : in `goal_occurrences` goal_occurrences : [`ident` [`at_occurrences`], ... , `ident` [`at_occurrences`] [|- [* [`at_occurrences`]]]] : * |- [* [`at_occurrences`]] @@ -2127,7 +2128,7 @@ and an explanation of the underlying technique. :name: discriminate This tactic proves any goal from an assumption stating that two - structurally different :n:`@terms` of an inductive set are equal. For + structurally different :n:`@term`\s of an inductive set are equal. For example, from :g:`(S (S O))=(S O)` we can derive by absurdity any proposition. @@ -2285,6 +2286,18 @@ and an explanation of the underlying technique. to the number of new equalities. The original equality is erased if it corresponds to a hypothesis. + .. tacv:: injection @term {? with @bindings_list} as @injection_intropattern + injection @num as @injection_intropattern + injection as @injection_intropattern + einjection @term {? with @bindings_list} as @injection_intropattern + einjection @num as @injection_intropattern + einjection as @injection_intropattern + + These are equivalent to the previous variants but using instead the + syntax :token:`injection_intropattern` which :tacn:`intros` + uses. In particular :n:`as [= {+ @simple_intropattern}]` behaves + the same as :n:`as {+ @simple_intropattern}`. + .. flag:: Structural Injection This option ensure that :n:`injection @term` erases the original hypothesis @@ -2294,7 +2307,7 @@ and an explanation of the underlying technique. .. flag:: Keep Proof Equalities - By default, :tacn:`injection` only creates new equalities between :n:`@terms` + By default, :tacn:`injection` only creates new equalities between :n:`@term`\s whose type is in sort :g:`Type` or :g:`Set`, thus implementing a special behavior for objects that are proofs of a statement in :g:`Prop`. This option controls this behavior. @@ -2703,42 +2716,42 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. Uses the equality :n:`@term`:sub:`1` :n:`= @term` :sub:`2` from right to left - .. tacv:: rewrite @term in clause + .. tacv:: rewrite @term in @goal_occurrences - Analogous to :n:`rewrite @term` but rewriting is done following clause - (similarly to :ref:`performing computations <performingcomputations>`). For instance: + Analogous to :n:`rewrite @term` but rewriting is done following + the clause :token:`goal_occurrences`. For instance: - + :n:`rewrite H in H`:sub:`1` will rewrite `H` in the hypothesis - `H`:sub:`1` instead of the current goal. - + :n:`rewrite H in H`:sub:`1` :g:`at 1, H`:sub:`2` :g:`at - 2 |- *` means - :n:`rewrite H; rewrite H in H`:sub:`1` :g:`at 1; rewrite H in H`:sub:`2` :g:`at - 2.` + + :n:`rewrite H in H'` will rewrite `H` in the hypothesis + ``H'`` instead of the current goal. + + :n:`rewrite H in H' at 1, H'' at - 2 |- *` means + :n:`rewrite H; rewrite H in H' at 1; rewrite H in H'' at - 2.` In particular a failure will happen if any of these three simpler tactics fails. - + :n:`rewrite H in * |-` will do :n:`rewrite H in H`:sub:`i` for all hypotheses - :g:`H`:sub:`i` different from :g:`H`. + + :n:`rewrite H in * |-` will do :n:`rewrite H in H'` for all hypotheses + :g:`H'` different from :g:`H`. A success will happen as soon as at least one of these simpler tactics succeeds. + :n:`rewrite H in *` is a combination of :n:`rewrite H` and :n:`rewrite H in * |-` that succeeds if at least one of these two tactics succeeds. Orientation :g:`->` or :g:`<-` can be inserted before the :token:`term` to rewrite. - .. tacv:: rewrite @term at occurrences + .. tacv:: rewrite @term at @occurrences - Rewrite only the given occurrences of :token:`term`. Occurrences are + Rewrite only the given :token:`occurrences` of :token:`term`. Occurrences are specified from left to right as for pattern (:tacn:`pattern`). The rewrite is always performed using setoid rewriting, even for Leibniz’s equality, so one has to ``Import Setoid`` to use this variant. - .. tacv:: rewrite @term by tactic + .. tacv:: rewrite @term by @tactic Use tactic to completely solve the side-conditions arising from the :tacn:`rewrite`. - .. tacv:: rewrite {+, @term} + .. tacv:: rewrite {+, @orientation @term} {? in @ident } Is equivalent to the `n` successive tactics :n:`{+; rewrite @term}`, each one - working on the first subgoal generated by the previous one. Orientation - :g:`->` or :g:`<-` can be inserted before each :token:`term` to rewrite. One + working on the first subgoal generated by the previous one. An :production:`orientation` + ``->`` or ``<-`` can be inserted before each :token:`term` to rewrite. One unique clause can be added at the end after the keyword in; it will then affect all rewrite operations. @@ -2799,13 +2812,14 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has the form :n:`@term’ = @term` - .. tacv:: replace @term {? with @term} in clause {? by @tactic} - replace -> @term in clause - replace <- @term in clause + .. tacv:: replace @term {? with @term} in @goal_occurrences {? by @tactic} + replace -> @term in @goal_occurrences + replace <- @term in @goal_occurrences - Acts as before but the replacements take place in the specified clause (see - :ref:`performingcomputations`) and not only in the conclusion of the goal. The - clause argument must not contain any ``type of`` nor ``value of``. + Acts as before but the replacements take place in the specified clauses + (:token:`goal_occurrences`) (see :ref:`performingcomputations`) and not + only in the conclusion of the goal. The clause argument must not contain + any ``type of`` nor ``value of``. .. tacv:: cutrewrite <- (@term = @term’) :name: cutrewrite @@ -2893,7 +2907,7 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. This applies :n:`stepl @term` then applies :token:`tactic` to the second goal. - .. tacv:: stepr @term stepr @term by tactic + .. tacv:: stepr @term by @tactic :name: stepr This behaves as :tacn:`stepl` but on the right-hand-side of the binary @@ -3064,7 +3078,7 @@ the conversion in hypotheses :n:`{+ @ident}`. .. tacv:: native_compute :name: native_compute - This tactic evaluates the goal by compilation to Objective Caml as described + This tactic evaluates the goal by compilation to OCaml as described in :cite:`FullReduction`. If Coq is running in native code, it can be typically two to five times faster than ``vm_compute``. Note however that the compilation cost is higher, so it is worth using only for intensive @@ -3159,7 +3173,7 @@ the conversion in hypotheses :n:`{+ @ident}`. + A constant can be marked to be unfolded only if applied to enough arguments. The number of arguments required can be specified using the - ``/`` symbol in the argument list of the :cmd:`Arguments` vernacular command. + ``/`` symbol in the argument list of the :cmd:`Arguments <Arguments (implicits)>` vernacular command. .. example:: @@ -3230,8 +3244,8 @@ the conversion in hypotheses :n:`{+ @ident}`. .. tacv:: simpl @pattern - This applies ``simpl`` only to the subterms matching :n:`@pattern` in the - current goal. + This applies :tacn:`simpl` only to the subterms matching + :n:`@pattern` in the current goal. .. tacv:: simpl @pattern at {+ @num} @@ -3264,50 +3278,77 @@ the conversion in hypotheses :n:`{+ @ident}`. This tactic applies to any goal. The argument qualid must denote a defined transparent constant or local definition (see - :ref:`gallina-definitions` and :ref:`vernac-controlling-the-reduction-strategies`). The tactic - ``unfold`` applies the :math:`\delta` rule to each occurrence of the constant to which - :n:`@qualid` refers in the current goal and then replaces it with its - :math:`\beta`:math:`\iota`-normal form. + :ref:`gallina-definitions` and + :ref:`vernac-controlling-the-reduction-strategies`). The tactic + :tacn:`unfold` applies the :math:`\delta` rule to each occurrence of + the constant to which :n:`@qualid` refers in the current goal and + then replaces it with its :math:`\beta`:math:`\iota`-normal form. -.. exn:: @qualid does not denote an evaluable constant. - :undocumented: + .. exn:: @qualid does not denote an evaluable constant. -.. tacv:: unfold @qualid in @ident + This error is frequent when trying to unfold something that has + defined as an inductive type (or constructor) and not as a + definition. - Replaces :n:`@qualid` in hypothesis :n:`@ident` with its definition - and replaces the hypothesis with its :math:`\beta`:math:`\iota` normal form. + .. example:: -.. tacv:: unfold {+, @qualid} + .. coqtop:: abort all fail - Replaces *simultaneously* :n:`{+, @qualid}` with their definitions and - replaces the current goal with its :math:`\beta`:math:`\iota` normal form. + Goal 0 <= 1. + unfold le. -.. tacv:: unfold {+, @qualid at {+, @num }} + This error can also be raised if you are trying to unfold + something that has been marked as opaque. - The lists :n:`{+, @num}` specify the occurrences of :n:`@qualid` to be - unfolded. Occurrences are located from left to right. + .. example:: - .. exn:: Bad occurrence number of @qualid. - :undocumented: + .. coqtop:: abort all fail - .. exn:: @qualid does not occur. - :undocumented: + Opaque Nat.add. + Goal 1 + 0 = 1. + unfold Nat.add. + + .. tacv:: unfold @qualid in @goal_occurrences -.. tacv:: unfold @string + Replaces :n:`@qualid` in hypothesis (or hypotheses) designated + by :token:`goal_occurrences` with its definition and replaces + the hypothesis with its :math:`\beta`:math:`\iota` normal form. - If :n:`@string` denotes the discriminating symbol of a notation (e.g. "+") or - an expression defining a notation (e.g. `"_ + _"`), and this notation refers to an unfoldable constant, then the - tactic unfolds it. + .. tacv:: unfold {+, @qualid} -.. tacv:: unfold @string%key + Replaces :n:`{+, @qualid}` with their definitions and replaces + the current goal with its :math:`\beta`:math:`\iota` normal + form. - This is variant of :n:`unfold @string` where :n:`@string` gets its - interpretation from the scope bound to the delimiting key :n:`key` - instead of its default interpretation (see :ref:`Localinterpretationrulesfornotations`). -.. tacv:: unfold {+, qualid_or_string at {+, @num}} + .. tacv:: unfold {+, @qualid at @occurrences } - This is the most general form, where :n:`qualid_or_string` is either a - :n:`@qualid` or a :n:`@string` referring to a notation. + The list :token:`occurrences` specify the occurrences of + :n:`@qualid` to be unfolded. Occurrences are located from left + to right. + + .. exn:: Bad occurrence number of @qualid. + :undocumented: + + .. exn:: @qualid does not occur. + :undocumented: + + .. tacv:: unfold @string + + If :n:`@string` denotes the discriminating symbol of a notation + (e.g. "+") or an expression defining a notation (e.g. `"_ + + _"`), and this notation denotes an application whose head symbol + is an unfoldable constant, then the tactic unfolds it. + + .. tacv:: unfold @string%@ident + + This is variant of :n:`unfold @string` where :n:`@string` gets + its interpretation from the scope bound to the delimiting key + :token:`ident` instead of its default interpretation (see + :ref:`Localinterpretationrulesfornotations`). + + .. tacv:: unfold {+, {| @qualid | @string{? %@ident } } {? at @occurrences } } {? in @goal_occurrences } + + This is the most general form. .. tacn:: fold @term :name: fold @@ -3382,14 +3423,13 @@ the conversion in hypotheses :n:`{+ @ident}`. Conversion tactics applied to hypotheses ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. tacn:: conv_tactic in {+, @ident} +.. tacn:: @tactic in {+, @ident} - Applies the conversion tactic :n:`conv_tactic` to the hypotheses - :n:`{+ @ident}`. The tactic :n:`conv_tactic` is any of the conversion tactics - listed in this section. + Applies :token:`tactic` (any of the conversion tactics listed in this + section) to the hypotheses :n:`{+ @ident}`. - If :n:`@ident` is a local definition, then :n:`@ident` can be replaced by - (type of :n:`@ident`) to address not the body but the type of the local + If :token:`ident` is a local definition, then :token:`ident` can be replaced by + :n:`type of @ident` to address not the body but the type of the local definition. Example: :n:`unfold not in (type of H1) (type of H3)`. @@ -3447,9 +3487,9 @@ Automation :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` for the list of pre-defined databases and the way to create or extend a database. - .. tacv:: auto using {+ @ident__i} {? with {+ @ident } } + .. tacv:: auto using {+ @qualid__i} {? with {+ @ident } } - Uses lemmas :n:`@ident__i` in addition to hints. If :n:`@ident` is an + Uses lemmas :n:`@qualid__i` in addition to hints. If :n:`@qualid` is an inductive type, it is the collection of its constructors which are added as hints. @@ -3457,8 +3497,8 @@ Automation The hints passed through the `using` clause are used in the same way as if they were passed through a hint database. Consequently, - they use a weaker version of :tacn:`apply` and :n:`auto using @ident` - may fail where :n:`apply @ident` succeeds. + they use a weaker version of :tacn:`apply` and :n:`auto using @qualid` + may fail where :n:`apply @qualid` succeeds. Given that this can be seen as counter-intuitive, it could be useful to have an option to use full-blown :tacn:`apply` for lemmas passed @@ -3476,7 +3516,7 @@ Automation Behaves like :tacn:`auto` but shows the tactics it tries to solve the goal, including failing paths. - .. tacv:: {? info_}auto {? @num} {? using {+ @lemma}} {? with {+ @ident}} + .. tacv:: {? info_}auto {? @num} {? using {+ @qualid}} {? with {+ @ident}} This is the most general form, combining the various options. @@ -3489,10 +3529,10 @@ Automation .. tacv:: trivial with {+ @ident} trivial with * - trivial using {+ @lemma} + trivial using {+ @qualid} debug trivial info_trivial - {? info_}trivial {? using {+ @lemma}} {? with {+ @ident}} + {? info_}trivial {? using {+ @qualid}} {? with {+ @ident}} :name: _; _; _; debug trivial; info_trivial; _ :undocumented: @@ -3531,7 +3571,7 @@ Automation Note that ``ex_intro`` should be declared as a hint. - .. tacv:: {? info_}eauto {? @num} {? using {+ @lemma}} {? with {+ @ident}} + .. tacv:: {? info_}eauto {? @num} {? using {+ @qualid}} {? with {+ @ident}} The various options for :tacn:`eauto` are the same as for :tacn:`auto`. @@ -3550,9 +3590,9 @@ Automation This tactic unfolds constants that were declared through a :cmd:`Hint Unfold` in the given databases. -.. tacv:: autounfold with {+ @ident} in clause +.. tacv:: autounfold with {+ @ident} in @goal_occurrences - Performs the unfolding in the given clause. + Performs the unfolding in the given clause (:token:`goal_occurrences`). .. tacv:: autounfold with * @@ -3592,10 +3632,9 @@ Automation Performs all the rewritings in hypothesis :n:`@qualid` applying :n:`@tactic` to the main subgoal after each rewriting step. -.. tacv:: autorewrite with {+ @ident} in @clause +.. tacv:: autorewrite with {+ @ident} in @goal_occurrences - Performs all the rewriting in the clause :n:`@clause`. The clause argument - must not contain any ``type of`` nor ``value of``. + Performs all the rewriting in the clause :n:`@goal_occurrences`. .. seealso:: @@ -3666,10 +3705,11 @@ automatically created. from the order in which they were inserted, making this implementation observationally different from the legacy one. -The general command to add a hint to some databases :n:`{+ @ident}` is - .. cmd:: Hint @hint_definition : {+ @ident} + The general command to add a hint to some databases :n:`{+ @ident}`. + The various possible :production:`hint_definition`\s are given below. + .. cmdv:: Hint @hint_definition No database name is given: the hint is registered in the ``core`` database. @@ -3714,11 +3754,11 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. cmdv:: Hint Resolve -> @term : @ident Adds the left-to-right implication of an equivalence as a hint (informally - the hint will be used as :n:`apply <- @term`, although as mentionned + the hint will be used as :n:`apply <- @term`, although as mentioned before, the tactic actually used is a restricted version of :tacn:`apply`). - .. cmdv:: Resolve <- @term + .. cmdv:: Hint Resolve <- @term Adds the right-to-left implication of an equivalence as a hint. @@ -3738,7 +3778,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. exn:: @term cannot be used as a hint :undocumented: - .. cmdv:: Immediate {+ @term} : @ident + .. cmdv:: Hint Immediate {+ @term} : @ident Adds each :n:`Hint Immediate @term`. @@ -3783,7 +3823,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is This sets the transparency flag used during unification of hints in the database for all constants or all variables, - overwritting the existing settings of opacity. It is advised + overwriting the existing settings of opacity. It is advised to use this just after a :cmd:`Create HintDb` command. .. cmdv:: Hint Extern @num {? @pattern} => @tactic : @ident @@ -3981,7 +4021,7 @@ use one or several databases specific to your development. Adds the rewriting rules :n:`{+ @term}` with a right-to-left orientation in the bases :n:`{+ @ident}`. -.. cmd:: Hint Rewrite {+ @term} using tactic : {+ @ident} +.. cmd:: Hint Rewrite {+ @term} using @tactic : {+ @ident} When the rewriting rules :n:`{+ @term}` in :n:`{+ @ident}` will be used, the tactic ``tactic`` will be applied to the generated subgoals, the main subgoal @@ -4202,7 +4242,7 @@ some incompatibilities. Adds lemmas from :tacn:`auto` hint bases :n:`{+ @ident}` to the proof-search environment. -.. tacv:: firstorder tactic using {+ @qualid} with {+ @ident} +.. tacv:: firstorder @tactic using {+ @qualid} with {+ @ident} This combines the effects of the different variants of :tacn:`firstorder`. @@ -4243,10 +4283,10 @@ some incompatibilities. congruence. Qed. -.. tacv:: congruence n +.. tacv:: congruence @num - Tries to add at most `n` instances of hypotheses stating quantified equalities - to the problem in order to solve it. A bigger value of `n` does not make + Tries to add at most :token:`num` instances of hypotheses stating quantified equalities + to the problem in order to solve it. A bigger value of :token:`num` does not make success slower, only failure. You might consider adding some lemmas as hypotheses using assert in order for :tacn:`congruence` to use them. @@ -4556,14 +4596,14 @@ Automating .. _btauto_grammar: .. productionlist:: sentence - t : `x` - : true - : false - : orb `t` `t` - : andb `t` `t` - : xorb `t` `t` - : negb `t` - : if `t` then `t` else `t` + btauto_term : `ident` + : true + : false + : orb `btauto_term` `btauto_term` + : andb `btauto_term` `btauto_term` + : xorb `btauto_term` `btauto_term` + : negb `btauto_term` + : if `btauto_term` then `btauto_term` else `btauto_term` Whenever the formula supplied is not a tautology, it also provides a counter-example. diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 26dc4e02cf..5f3e82938d 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -189,18 +189,13 @@ Requests to the environment This command displays the type of :n:`@term`. When called in proof mode, the term is checked in the local context of the current subgoal. - - .. TODO : selector is not a syntax entry - .. cmdv:: @selector: Check @term This variant specifies on which subgoal to perform typing (see Section :ref:`invocation-of-tactics`). -.. TODO : convtactic is not a syntax entry - -.. cmd:: Eval @convtactic in @term +.. cmd:: Eval @redexpr in @term This command performs the specified reduction on :n:`@term`, and displays the resulting term with its type. The term to be reduced may depend on @@ -264,11 +259,11 @@ Requests to the environment main symbol as in `"+"` or by its notation’s string as in `"_ + _"` or `"_ 'U' _"`, see Section :ref:`notations`), the command works like ``Search`` :n:`@qualid`. - .. cmdv:: Search @string%@key + .. cmdv:: Search @string%@ident The string string must be a notation or the main symbol of a notation which is then interpreted in the scope bound to - the delimiting key :n:`@key` (see Section :ref:`LocalInterpretationRulesForNotations`). + the delimiting key :token:`ident` (see Section :ref:`LocalInterpretationRulesForNotations`). .. cmdv:: Search @term_pattern @@ -1132,6 +1127,8 @@ described first. with lower level is expanded first. In case of a tie, the second one (appearing in the cast type) is expanded. + .. prodn:: level ::= {| opaque | @num | expand } + Levels can be one of the following (higher to lower): + ``opaque`` : level of opaque constants. They cannot be expanded by @@ -1167,19 +1164,19 @@ described first. Print all the currently non-transparent strategies. -.. cmd:: Declare Reduction @ident := @convtactic +.. cmd:: Declare Reduction @ident := @redexpr This command allows giving a short name to a reduction expression, for - instance lazy beta delta [foo bar]. This short name can then be used + instance ``lazy beta delta [foo bar]``. This short name can then be used in :n:`Eval @ident in` or ``eval`` directives. This command accepts the - Local modifier, for discarding this reduction name at the end of the - file or module. For the moment the name cannot be qualified. In + ``Local`` modifier, for discarding this reduction name at the end of the + file or module. For the moment, the name is not qualified. In particular declaring the same name in several modules or in several - functor applications will be refused if these declarations are not + functor applications will be rejected if these declarations are not local. The name :n:`@ident` cannot be used directly as an Ltac tactic, but - nothing prevents the user to also perform a - :n:`Ltac @ident := @convtactic`. + nothing prevents the user from also performing a + :n:`Ltac @ident := @redexpr`. .. seealso:: :ref:`performingcomputations` @@ -1208,7 +1205,7 @@ Controlling the locality of commands effect of the command to the current module if the command does not occur in a section and the Global modifier extends the effect outside the current sections and current module if the command occurs in a section. As an example, - the :cmd:`Arguments`, :cmd:`Ltac` or :cmd:`Notation` commands belong + the :cmd:`Arguments <Arguments (implicits)>`, :cmd:`Ltac` or :cmd:`Notation` commands belong to this category. Notice that a subclass of these commands do not support extension of their scope outside sections at all and the Global modifier is not applicable to them. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index cda228a7da..9b381cb9de 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -109,7 +109,7 @@ the associativity of disjunction and conjunction, so let us apply for instance a right associativity (which is the choice of Coq). Precedence levels and associativity rules of notations have to be -given between parentheses in a list of modifiers that the :cmd:`Notation` +given between parentheses in a list of :token:`modifiers` that the :cmd:`Notation` command understands. Here is how the previous examples refine. .. coqtop:: in @@ -249,7 +249,7 @@ bar of the notation. Check (sig (fun x : nat => x=x)). The second, more powerful control on printing is by using the format -modifier. Here is an example +:token:`modifier`. Here is an example .. coqtop:: all @@ -298,8 +298,8 @@ expression is performed at definition time. Type checking is done only at the time of use of the notation. .. note:: Sometimes, a notation is expected only for the parser. To do - so, the option ``only parsing`` is allowed in the list of modifiers - of :cmd:`Notation`. Conversely, the ``only printing`` modifier can be + so, the option ``only parsing`` is allowed in the list of :token:`modifiers` + of :cmd:`Notation`. Conversely, the ``only printing`` :token:`modifier` can be used to declare that a notation should only be used for printing and should not declare a parsing rule. In particular, such notations do not modify the parser. @@ -310,11 +310,11 @@ The Infix command The :cmd:`Infix` command is a shortening for declaring notations of infix symbols. -.. cmd:: Infix "@symbol" := @term ({+, @modifier}). +.. cmd:: Infix "@symbol" := @term {? (@modifiers) }. This command is equivalent to - :n:`Notation "x @symbol y" := (@term x y) ({+, @modifier}).` + :n:`Notation "x @symbol y" := (@term x y) {? (@modifiers) }.` where ``x`` and ``y`` are fresh names. Here is an example. @@ -437,7 +437,7 @@ application of the notation: Check sigma z : nat, z = 0. -Notice the modifier ``x ident`` in the declaration of the +Notice the :token:`modifier` ``x ident`` in the declaration of the notation. It tells to parse :g:`x` as a single identifier. Binders bound in the notation and parsed as patterns @@ -457,7 +457,7 @@ binder. Here is an example: Check subset '(x,y), x+y=0. -The modifier ``p pattern`` in the declaration of the notation tells to parse +The :token:`modifier` ``p pattern`` in the declaration of the notation tells to parse :g:`p` as a pattern. Note that a single variable is both an identifier and a pattern, so, e.g., the following also works: @@ -467,7 +467,7 @@ pattern, so, e.g., the following also works: If one wants to prevent such a notation to be used for printing when the pattern is reduced to a single identifier, one has to use instead -the modifier ``p strict pattern``. For parsing, however, a +the :token:`modifier` ``p strict pattern``. For parsing, however, a ``strict pattern`` will continue to include the case of a variable. Here is an example showing the difference: @@ -507,7 +507,7 @@ that ``x`` is parsed as a term at level 99 (as done in the notation for :g:`sumbool`), but that this term has actually to be an identifier. The notation :g:`{ x | P }` is already defined in the standard -library with the ``as ident`` modifier. We cannot redefine it but +library with the ``as ident`` :token:`modifier`. We cannot redefine it but one can define an alternative notation, say :g:`{ p such that P }`, using instead ``as pattern``. @@ -527,7 +527,7 @@ is just an identifier, one could have said ``p at level 99 as strict pattern``. Note also that in the absence of a ``as ident``, ``as strict pattern`` or -``as pattern`` modifiers, the default is to consider sub-expressions occurring +``as pattern`` :token:`modifier`\s, the default is to consider sub-expressions occurring in binding position and parsed as terms to be ``as ident``. .. _NotationsWithBinders: @@ -628,7 +628,7 @@ except that in the iterator position of the binding variable of a ``fun`` or a ``forall``. To specify that the part “``x .. y``” of the notation parses a sequence of -binders, ``x`` and ``y`` must be marked as ``binder`` in the list of modifiers +binders, ``x`` and ``y`` must be marked as ``binder`` in the list of :token:`modifiers` of the notation. The binders of the parsed sequence are used to fill the occurrences of the first placeholder of the iterating pattern which is repeatedly nested as many times as the number of binders generated. If ever the @@ -678,7 +678,7 @@ Predefined entries ~~~~~~~~~~~~~~~~~~ By default, sub-expressions are parsed as terms and the corresponding -grammar entry is called :n:`@constr`. However, one may sometimes want +grammar entry is called ``constr``. However, one may sometimes want to restrict the syntax of terms in a notation. For instance, the following notation will accept to parse only global reference in position of :g:`x`: @@ -866,16 +866,17 @@ notations are given below. The optional :production:`scope` is described in :ref:`Scopes`. .. productionlist:: coq - notation : [Local] Notation `string` := `term` [`modifiers`] [: `scope`]. - : [Local] Infix `string` := `qualid` [`modifiers`] [: `scope`]. - : [Local] Reserved Notation `string` [`modifiers`] . + notation : [Local] Notation `string` := `term` [(`modifiers`)] [: `scope`]. + : [Local] Infix `string` := `qualid` [(`modifiers`)] [: `scope`]. + : [Local] Reserved Notation `string` [(`modifiers`)] . : Inductive `ind_body` [`decl_notation`] with … with `ind_body` [`decl_notation`]. : CoInductive `ind_body` [`decl_notation`] with … with `ind_body` [`decl_notation`]. : Fixpoint `fix_body` [`decl_notation`] with … with `fix_body` [`decl_notation`]. : CoFixpoint `cofix_body` [`decl_notation`] with … with `cofix_body` [`decl_notation`]. : [Local] Declare Custom Entry `ident`. decl_notation : [where `string` := `term` [: `scope`] and … and `string` := `term` [: `scope`]]. - modifiers : at level `num` + modifiers : `modifier`, … , `modifier` + modifier : at level `num` : in custom `ident` : in custom `ident` at level `num` : `ident` , … , `ident` at level `num` [`binderinterp`] @@ -924,6 +925,17 @@ notations are given below. The optional :production:`scope` is described in given to some notation, say ``"{ y } & { z }"`` in fact applies to the underlying ``"{ x }"``\-free rule which is ``"y & z"``). +.. note:: Notations such as ``"( p | q )"`` (or starting with ``"( x | "``, + more generally) are deprecated as they conflict with the syntax for + nested disjunctive patterns (see :ref:`extendedpatternmatching`), + and are not honored in pattern expressions. + + .. warn:: Use of @string Notation is deprecated as it is inconsistent with pattern syntax. + + This warning is disabled by default to avoid spurious diagnostics + due to legacy notation in the Coq standard library. + It can be turned on with the ``-w disj-pattern-notation`` flag. + Persistence of notations ++++++++++++++++++++++++ @@ -1032,11 +1044,11 @@ Local opening of an interpretation scope +++++++++++++++++++++++++++++++++++++++++ It is possible to locally extend the interpretation scope stack using the syntax -:g:`(term)%key` (or simply :g:`term%key` for atomic terms), where key is a +:n:`(@term)%@ident` (or simply :n:`@term%@ident` for atomic terms), where :token:`ident` is a special identifier called *delimiting key* and bound to a given scope. In such a situation, the term term, and all its subterms, are -interpreted in the scope stack extended with the scope bound tokey. +interpreted in the scope stack extended with the scope bound to :token:`ident`. .. cmd:: Delimit Scope @scope with @ident @@ -1051,15 +1063,15 @@ interpreted in the scope stack extended with the scope bound tokey. Binding arguments of a constant to an interpretation scope +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -.. cmd:: Arguments @qualid {+ @name%@scope} +.. cmd:: Arguments @qualid {+ @name%@ident} :name: Arguments (scopes) It is possible to set in advance that some arguments of a given constant have to be interpreted in a given scope. The command is - :n:`Arguments @qualid {+ @name%@scope}` where the list is a prefix of the - arguments of ``qualid`` eventually annotated with their ``scope``. Grouping + :n:`Arguments @qualid {+ @name%@ident}` where the list is a prefix of the + arguments of ``qualid`` optionally annotated with their scope :token:`ident`. Grouping round parentheses can be used to decorate multiple arguments with the same - scope. ``scope`` can be either a scope name or its delimiting key. For + scope. :token:`ident` can be either a scope name or its delimiting key. For example the following command puts the first two arguments of :g:`plus_fct` in the scope delimited by the key ``F`` (``Rfun_scope``) and the last argument in the scope delimited by the key ``R`` (``R_scope``). @@ -1070,13 +1082,13 @@ Binding arguments of a constant to an interpretation scope The ``Arguments`` command accepts scopes decoration to all grouping parentheses. In the following example arguments A and B are marked as - maximally inserted implicit arguments and are put into the type_scope scope. + maximally inserted implicit arguments and are put into the ``type_scope`` scope. .. coqdoc:: Arguments respectful {A B}%type (R R')%signature _ _. - When interpreting a term, if some of the arguments of qualid are built + When interpreting a term, if some of the arguments of :token:`qualid` are built from a notation, then this notation is interpreted in the scope stack extended by the scope bound (if any) to this argument. The effect of the scope is limited to the argument itself. It does not propagate to @@ -1088,21 +1100,21 @@ Binding arguments of a constant to an interpretation scope This command can be used to clear argument scopes of :token:`qualid`. - .. cmdv:: Arguments @qualid {+ @name%scope} : extra scopes + .. cmdv:: Arguments @qualid {+ @name%@ident} : extra scopes Defines extra argument scopes, to be used in case of coercion to ``Funclass`` (see the :ref:`implicitcoercions` chapter) or with a computed type. - .. cmdv:: Global Arguments @qualid {+ @name%@scope} + .. cmdv:: Global Arguments @qualid {+ @name%@ident} - This behaves like :n:`Arguments qualid {+ @name%@scope}` but survives when a + This behaves like :n:`Arguments qualid {+ @name%@ident}` but survives when a section is closed instead of stopping working at section closing. Without the ``Global`` modifier, the effect of the command stops when the section it belongs to ends. - .. cmdv:: Local Arguments @qualid {+ @name%@scope} + .. cmdv:: Local Arguments @qualid {+ @name%@ident} - This behaves like :n:`Arguments @qualid {+ @name%@scope}` but does not + This behaves like :n:`Arguments @qualid {+ @name%@ident}` but does not survive modules and files. Without the ``Local`` modifier, the effect of the command is visible from within other modules or files. @@ -1141,10 +1153,10 @@ Binding types of arguments to an interpretation scope When an interpretation scope is naturally associated to a type (e.g. the scope of operations on the natural numbers), it may be convenient to bind it - to this type. When a scope ``scope`` is bound to a type ``type``, any new function - defined later on gets its arguments of type ``type`` interpreted by default in - scope scope (this default behavior can however be overwritten by explicitly - using the command :cmd:`Arguments`). + to this type. When a scope :token:`scope` is bound to a type :token:`type`, any function + gets its arguments of type :token:`type` interpreted by default in scope :token:`scope` + (this default behavior can however be overwritten by explicitly using the + command :cmd:`Arguments <Arguments (scopes)>`). Whether the argument of a function has some type ``type`` is determined statically. For instance, if ``f`` is a polymorphic function of type @@ -1172,6 +1184,11 @@ Binding types of arguments to an interpretation scope Check (fun x y1 y2 z t => P _ (x + t) ((f _ (y1 + y2) + z))). + .. note:: When active, a bound scope has effect on all defined functions + (even if they are defined after the :cmd:`Bind Scope` directive), except + if argument scopes were assigned explicitly using the + :cmd:`Arguments <Arguments (scopes)>` command. + .. note:: The scopes ``type_scope`` and ``function_scope`` also have a local effect on interpretation. See the next section. @@ -1198,7 +1215,7 @@ The ``function_scope`` interpretation scope The scope ``function_scope`` also has a special status. It is temporarily activated each time the argument of a global reference is -recognized to be a ``Funclass`` istance, i.e., of type :g:`forall x:A, B` or +recognized to be a ``Funclass`` instance, i.e., of type :g:`forall x:A, B` or :g:`A -> B`. @@ -1657,15 +1674,15 @@ Tactic notations allow to customize the syntax of tactics. They have the followi tacn : Tactic Notation [`tactic_level`] [`prod_item` … `prod_item`] := `tactic`. prod_item : `string` | `tactic_argument_type`(`ident`) tactic_level : (at level `num`) - tactic_argument_type : `ident` | `simple_intropattern` | `reference` - : `hyp` | `hyp_list` | `ne_hyp_list` - : `constr` | `uconstr` | `constr_list` | `ne_constr_list` - : `integer` | `integer_list` | `ne_integer_list` - : `int_or_var` | `int_or_var_list` | `ne_int_or_var_list` - : `tactic` | `tactic0` | `tactic1` | `tactic2` | `tactic3` - : `tactic4` | `tactic5` - -.. cmd:: Tactic Notation {? (at level @level)} {+ @prod_item} := @tactic. + tactic_argument_type : ident | simple_intropattern | reference + : hyp | hyp_list | ne_hyp_list + : constr | uconstr | constr_list | ne_constr_list + : integer | integer_list | ne_integer_list + : int_or_var | int_or_var_list | ne_int_or_var_list + : tactic | tactic0 | tactic1 | tactic2 | tactic3 + : tactic4 | tactic5 + +.. cmd:: Tactic Notation {? (at level @num)} {+ @prod_item} := @tactic. A tactic notation extends the parser and pretty-printer of tactics with a new rule made of the list of production items. It then evaluates into the diff --git a/doc/tools/Translator.tex b/doc/tools/Translator.tex index d8ac640f2a..dde8a7b838 100644 --- a/doc/tools/Translator.tex +++ b/doc/tools/Translator.tex @@ -412,7 +412,7 @@ but its behaviour is not to fold the abbreviation at all.}. {\tt LetTac} could be followed by a specification (called a clause) of the places where the abbreviation had to be folded (hypothese and/or conclusion). Clauses are the syntactic notion to denote in which parts -of a goal a given transformation shold occur. Its basic notation is +of a goal a given transformation should occur. Its basic notation is either \TERM{*} (meaning everywhere), or {\tt\textrm{\em hyps} |- \textrm{\em concl}} where {\em hyps} is either \TERM{*} (to denote all the hypotheses), or a comma-separated list of either hypothesis name, @@ -620,7 +620,7 @@ These constraints are met by the makefiles produced by {\tt coq\_makefile} Otherwise, modify your build program so as to pass option {\tt -translate} to program {\tt coqc}. The effect of this option is to -ouptut the translated source of any {\tt .v} file in a file with +output the translated source of any {\tt .v} file in a file with extension {\tt .v8} located in the same directory than the original file. @@ -675,7 +675,7 @@ solve all occurrences of the problem. The definition of identifiers changed. Most of those changes are handled by the translator. They include: \begin{itemize} -\item {\tt \_} is not an identifier anymore: it is tranlated to {\tt +\item {\tt \_} is not an identifier anymore: it is translated to {\tt x\_} \item avoid clash with new keywords by adding a trailing {\tt \_} \end{itemize} diff --git a/doc/tools/coqrst/coqdoc/main.py b/doc/tools/coqrst/coqdoc/main.py index 1de9890992..ba58ff0084 100644 --- a/doc/tools/coqrst/coqdoc/main.py +++ b/doc/tools/coqrst/coqdoc/main.py @@ -52,7 +52,7 @@ def is_whitespace_string(elem): return isinstance(elem, NavigableString) and elem.strip() == "" def strip_soup(soup, pred): - """Strip elements maching pred from front and tail of soup.""" + """Strip elements matching pred from front and tail of soup.""" while soup.contents and pred(soup.contents[-1]): soup.contents.pop() diff --git a/doc/tools/coqrst/repl/coqtop.py b/doc/tools/coqrst/repl/coqtop.py index 26f6255069..2b124ee5c1 100644 --- a/doc/tools/coqrst/repl/coqtop.py +++ b/doc/tools/coqrst/repl/coqtop.py @@ -47,7 +47,7 @@ class CoqTop: :param coqtop_bin: The path to coqtop; uses $COQBIN by default, falling back to "coqtop" :param color: When True, tell coqtop to produce ANSI color codes (see the ansicolors module) - :param args: Additional arugments to coqtop. + :param args: Additional arguments to coqtop. """ self.coqtop_bin = coqtop_bin or os.path.join(os.getenv('COQBIN', ""), "coqtop") if not pexpect.utils.which(self.coqtop_bin): @@ -68,7 +68,7 @@ class CoqTop: self.coqtop.kill(9) def next_prompt(self): - """Wait for the next coqtop prompt, and return the output preceeding it.""" + """Wait for the next coqtop prompt, and return the output preceding it.""" self.coqtop.expect(CoqTop.COQTOP_PROMPT, timeout = 10) return self.coqtop.before diff --git a/doc/whodidwhat/whodidwhat-8.2update.tex b/doc/whodidwhat/whodidwhat-8.2update.tex index 4f4f0e952e..f45e6564f2 100644 --- a/doc/whodidwhat/whodidwhat-8.2update.tex +++ b/doc/whodidwhat/whodidwhat-8.2update.tex @@ -181,7 +181,7 @@ \item Options management: Hugo Herbelin with contributions by Arnaud Spiwack \item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu \item Searching: Hugo Herbelin, Yves Bertot -\item Whelp suppport: Hugo Herbelin +\item Whelp support: Hugo Herbelin \end{itemize} \section{Parsing and printing} diff --git a/doc/whodidwhat/whodidwhat-8.3update.tex b/doc/whodidwhat/whodidwhat-8.3update.tex index 0a07378169..7cce0083d5 100644 --- a/doc/whodidwhat/whodidwhat-8.3update.tex +++ b/doc/whodidwhat/whodidwhat-8.3update.tex @@ -188,7 +188,7 @@ \item Options management: Hugo Herbelin with contributions by Arnaud Spiwack \item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu \item Searching: Hugo Herbelin and Yves Bertot with extensions by Matthias Puech -\item Whelp suppport: Hugo Herbelin +\item Whelp support: Hugo Herbelin \end{itemize} \section{Parsing and printing} diff --git a/doc/whodidwhat/whodidwhat-8.4update.tex b/doc/whodidwhat/whodidwhat-8.4update.tex index bb4c5ce469..2d74a653ed 100644 --- a/doc/whodidwhat/whodidwhat-8.4update.tex +++ b/doc/whodidwhat/whodidwhat-8.4update.tex @@ -191,7 +191,7 @@ \item Options management: Hugo Herbelin with contributions by Arnaud Spiwack \item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu \item Searching: Hugo Herbelin and Yves Bertot with extensions by Matthias Puech -\item Whelp suppport: Hugo Herbelin +\item Whelp support: Hugo Herbelin \end{itemize} \section{Parsing and printing} diff --git a/doc/whodidwhat/whodidwhat-8.5update.tex b/doc/whodidwhat/whodidwhat-8.5update.tex index ce099dc363..600ecf93db 100644 --- a/doc/whodidwhat/whodidwhat-8.5update.tex +++ b/doc/whodidwhat/whodidwhat-8.5update.tex @@ -197,7 +197,7 @@ \item Options management: Hugo Herbelin with contributions by Arnaud Spiwack \item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu \item Searching: Hugo Herbelin and Yves Bertot with extensions by Matthias Puech -\item Whelp suppport: Hugo Herbelin +\item Whelp support: Hugo Herbelin \end{itemize} \section{Parsing and printing} diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 0a5bba39b9..7c2ecca89e 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -860,7 +860,7 @@ let compare_constructor_instances evd u u' = [u] up to existential variable instantiation and equalisable universes. The term [t] is interpreted in [sigma1] while [u] is interpreted in [sigma2]. The universe constraints in [sigma2] are - assumed to be an extention of those in [sigma1]. *) + assumed to be an extension of those in [sigma1]. *) let eq_constr_univs_test sigma1 sigma2 t u = (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *) let open Evd in diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 8eaff8bd13..907be8eba2 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -208,7 +208,7 @@ val kind_of_term_upto : evar_map -> Constr.constr -> [u] up to existential variable instantiation and equalisable universes. The term [t] is interpreted in [sigma1] while [u] is interpreted in [sigma2]. The universe constraints in [sigma2] are - assumed to be an extention of those in [sigma1]. *) + assumed to be an extension of those in [sigma1]. *) val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool (** [compare_cumulative_instances cv_pb variance u1 u2 sigma] Returns diff --git a/engine/ftactic.ml b/engine/ftactic.ml index dab2e7d5ef..b59d04e813 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -18,8 +18,8 @@ type 'a focus = (** Type of tactics potentially goal-dependent. If it contains a [Depends], then the length of the inner list is guaranteed to be the number of - currently focussed goals. Otherwise it means the tactic does not depend - on the current set of focussed goals. *) + currently focused goals. Otherwise it means the tactic does not depend + on the current set of focused goals. *) type 'a t = 'a focus Proofview.tactic let return (x : 'a) : 'a t = Proofview.tclUNIT (Uniform x) diff --git a/engine/ftactic.mli b/engine/ftactic.mli index ed95d62bc6..5922781d4d 100644 --- a/engine/ftactic.mli +++ b/engine/ftactic.mli @@ -18,7 +18,7 @@ type +'a t = 'a focus Proofview.tactic (** The type of focussing tactics. A focussing tactic is like a normal tactic, except that it is able to remember it have entered a goal. Whenever this is the case, each subsequent effect of the tactic is dispatched on the - focussed goals. This is a monad. *) + focused goals. This is a monad. *) (** {5 Monadic interface} *) @@ -32,20 +32,20 @@ val bind : 'a t -> ('a -> 'b t) -> 'b t val lift : 'a Proofview.tactic -> 'a t (** Transform a tactic into a focussing tactic. The resulting tactic is not - focussed. *) + focused. *) val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** Given a continuation producing a tactic, evaluates the focussing tactic. If - the tactic has not focussed, then the continuation is evaluated once. - Otherwise it is called in each of the currently focussed goals. *) + the tactic has not focused, then the continuation is evaluated once. + Otherwise it is called in each of the currently focused goals. *) (** {5 Focussing} *) -(** Enter a goal. The resulting tactic is focussed. *) +(** Enter a goal. The resulting tactic is focused. *) val enter : (Proofview.Goal.t -> 'a t) -> 'a t (** Enter a goal, without evar normalization. The resulting tactic is - focussed. *) + focused. *) val with_env : 'a t -> (Environ.env*'a) t (** [with_env t] returns, in addition to the return type of [t], an diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index e0c24f049f..a504ee28e2 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -151,7 +151,7 @@ struct (** Double-continuation backtracking monads are reasonable folklore for "search" implementations (including the Tac interactive prover's tactics). Yet it's quite hard to wrap your head around - these. I recommand reading a few times the "Backtracking, + these. I recommend reading a few times the "Backtracking, Interleaving, and Terminating Monad Transformers" paper by O. Kiselyov, C. Shan, D. Friedman, and A. Sabry. The peculiar shape of the monadic type is reminiscent of that of the diff --git a/engine/proofview.ml b/engine/proofview.ml index 5c5a02d3fa..c00c90e5e9 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -31,7 +31,7 @@ type entry = (EConstr.constr * EConstr.types) list ide-s. *) (* spiwack: the type of [proofview] will change as we push more refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) + new nearly identical function every time. Hence the generic name. *) (* In this version: returns the list of focused goals together with the [evar_map] context. *) let proofview p = @@ -114,7 +114,7 @@ type focus_context = goal_with_state list * goal_with_state list instance, ide-s. *) (* spiwack: the type of [focus_context] will change as we push more refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) + new nearly identical function every time. Hence the generic name. *) (* In this version: the goals in the context, as a "zipper" (the first list is in reversed order). *) let focus_context (left,right) = @@ -123,7 +123,7 @@ let focus_context (left,right) = (** This (internal) function extracts a sublist between two indices, and returns this sublist together with its context: if it returns [(a,(b,c))] then [a] is the sublist and [(rev b) @ a @ c] is the - original list. The focused list has lenght [j-i-1] and contains + original list. The focused list has length [j-i-1] and contains the goals from number [i] to number [j] (both included) the first goal of the list being numbered [1]. [focus_sublist i j l] raises [IndexOutOfRange] if [i > length l], or [j > length l] or [j < @@ -245,7 +245,7 @@ let tclUNIT = Proof.return (** Bind operation of the tactic monad. *) let tclBIND = Proof.(>>=) -(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation, +(** Interprets the ";" (semicolon) of Ltac. As a monadic operation, it's a specialized "bind". *) let tclTHEN = Proof.(>>) diff --git a/engine/proofview.mli b/engine/proofview.mli index b7ff3ac432..60697c1611 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -24,7 +24,7 @@ type proofview ide-s. *) (* spiwack: the type of [proofview] will change as we push more refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) + new nearly identical function every time. Hence the generic name. *) (* In this version: returns the list of focused goals together with the [evar_map] context. *) val proofview : proofview -> Evar.t list * Evd.evar_map @@ -95,7 +95,7 @@ type focus_context instance, ide-s. *) (* spiwack: the type of [focus_context] will change as we push more refined functions to ide-s. This would be better than spawning a - new nearly identical function everytime. Hence the generic name. *) + new nearly identical function every time. Hence the generic name. *) (* In this version: the goals in the context, as a "zipper" (the first list is in reversed order). *) val focus_context : focus_context -> Evar.t list * Evar.t list diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 80eb9d0124..8ed75a8d00 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -252,7 +252,7 @@ module Giveup : Writer with type t = goal list = struct let put gs = Logical.put (true, gs) end -(** Lens and utilies pertaining to the info trace *) +(** Lens and utilities pertaining to the info trace *) module InfoL = struct let recording = Logical.(map (fun {P.trace} -> trace) current) let if_recording t = diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index 3437b6ce77..f0c9fdb589 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -145,7 +145,7 @@ module Shelf : State with type t = goal list of the tactic. *) module Giveup : Writer with type t = goal list -(** Lens and utilies pertaining to the info trace *) +(** Lens and utilities pertaining to the info trace *) module InfoL : sig (** [record_trace t] behaves like [t] and compute its [info] trace. *) val record_trace : 'a Logical.t -> 'a Logical.t diff --git a/engine/termops.ml b/engine/termops.ml index fcacb53ac4..05bb42ac61 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -306,9 +306,15 @@ let pr_evar_map_gen with_univs pr_evars env sigma = let pr_evar_list env sigma l = let open Evd in + let pr_restrict ev = + match is_restricted_evar sigma ev with + | None -> mt () + | Some ev' -> str " (restricted to " ++ Evar.print ev' ++ str ")" + in let pr (ev, evi) = h 0 (Evar.print ev ++ str "==" ++ pr_evar_info env sigma evi ++ + pr_restrict ev ++ (if evi.evar_body == Evar_empty then str " {" ++ pr_existential_key sigma ev ++ str "}" else mt ())) diff --git a/engine/univMinim.ml b/engine/univMinim.ml index fcbf305f9d..4f9f9ce6a5 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -353,7 +353,7 @@ let normalize_context_set g ctx us algs weak = noneqs Constraint.empty in (* Compute the left and right set of flexible variables, constraints - mentionning other variables remain in noneqs. *) + mentioning other variables remain in noneqs. *) let noneqs, ucstrsl, ucstrsr = Constraint.fold (fun (l,d,r as cstr) (noneq, ucstrsl, ucstrsr) -> let lus = LMap.mem l us and rus = LMap.mem r us in diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index c452c7b307..f9d18e7190 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -222,7 +222,7 @@ let is_before : type s1 s2 r1 r2 a1 a2. (s1, r1, a1) ty_symbol -> (s2, r2, a2) t | Stoken _, _ -> true | _ -> false -(** Ancilliary datatypes *) +(** Ancillary datatypes *) type 'a ty_rec = MayRec : ty_mayrec ty_rec | NoRec : ty_norec ty_rec diff --git a/ide/configwin_types.ml b/ide/configwin_types.ml index 251e3dded3..4c66a6944e 100644 --- a/ide/configwin_types.ml +++ b/ide/configwin_types.ml @@ -87,7 +87,7 @@ type modifiers_param = { (** The value, as a list of modifiers and a key code *) md_editable : bool ; (** indicates if the value can be changed *) md_f_apply : Gdk.Tags.modifier list -> unit ; - (** the function to call to apply the new value of the paramter *) + (** the function to call to apply the new value of the parameter *) md_help : string option ; (** optional help string *) md_expand : bool ; (** expand or not *) md_allow : Gdk.Tags.modifier list 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/ide/protocol/interface.ml b/ide/protocol/interface.ml index ccb6bedaf6..9d8fdf6335 100644 --- a/ide/protocol/interface.ml +++ b/ide/protocol/interface.ml @@ -34,7 +34,7 @@ type status = { status_path : string list; (** Module path of the current proof *) status_proofname : string option; - (** Current proof name. [None] if no focussed proof is in progress *) + (** Current proof name. [None] if no focused proof is in progress *) status_allproofs : string list; (** List of all pending proofs. Order is not significant *) status_proofnum : int; @@ -43,7 +43,7 @@ type status = { type 'a pre_goals = { fg_goals : 'a list; - (** List of the focussed goals *) + (** List of the focused goals *) bg_goals : ('a list * 'a list) list; (** Zipper representing the unfocused background goals *) shelved_goals : 'a list; @@ -70,7 +70,7 @@ type option_state = { opt_sync : bool; (** Whether an option is synchronous *) opt_depr : bool; - (** Wheter an option is deprecated *) + (** Whether an option is deprecated *) opt_name : string; (** A short string that is displayed when using [Test] *) opt_value : option_value; diff --git a/ide/protocol/richpp.mli b/ide/protocol/richpp.mli index 31fc7b56f1..18d4b1eeee 100644 --- a/ide/protocol/richpp.mli +++ b/ide/protocol/richpp.mli @@ -25,7 +25,7 @@ type 'annotation located = { of [ppcmds] as a semi-structured document that represents (located) annotations of this string. The [get_annotations] function is used to convert tags into the desired - annotation. [width] sets the printing witdh of the formatter. *) + annotation. [width] sets the printing width of the formatter. *) val rich_pp : int -> Pp.t -> Pp.pp_tag located Xml_datatype.gxml (** [annotations_positions ssdoc] returns a list associating each diff --git a/ide/protocol/xml_printer.mli b/ide/protocol/xml_printer.mli index 178f7c808f..4b47aa9f7c 100644 --- a/ide/protocol/xml_printer.mli +++ b/ide/protocol/xml_printer.mli @@ -16,11 +16,11 @@ type target = TChannel of out_channel | TBuffer of Buffer.t val make : target -> t (** Print the xml data structure to a source into a compact xml string (without - any user-readable formating ). *) + any user-readable formatting ). *) val print : t -> xml -> unit (** Print the xml data structure into a compact xml string (without - any user-readable formating ). *) + any user-readable formatting ). *) val to_string : xml -> string (** Print the xml data structure into an user-readable string with diff --git a/ide/protocol/xmlprotocol.ml b/ide/protocol/xmlprotocol.ml index e18219210f..5b37ca35ed 100644 --- a/ide/protocol/xmlprotocol.ml +++ b/ide/protocol/xmlprotocol.ml @@ -405,7 +405,7 @@ end = struct | (lg, rg) :: l -> Printf.sprintf "%i:%a" (List.length lg + List.length rg) pr_focus l in - Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals + Printf.sprintf "Still focused: [%a]." pr_focus g.bg_goals else let pr_goal { goal_hyp = hyps; goal_ccl = goal } = "[" ^ String.concat "; " (List.map Pp.string_of_ppcmds hyps) ^ " |- " ^ diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 9f778d99e9..3ebbbdfb88 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -40,8 +40,8 @@ type explicitation = type binder_kind = | Default of binding_kind - | Generalized of binding_kind * binding_kind * bool - (** Inner binding, outer bindings, typeclass-specific flag + | Generalized of binding_kind * bool + (** (Inner binding always Implicit) Outer bindings, typeclass-specific flag for implicit generalization of superclasses *) type abstraction_kind = AbsLambda | AbsPi diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 443473d5b6..bcb2f34377 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -34,8 +34,8 @@ let abstraction_kind_eq ak1 ak2 = match ak1, ak2 with let binder_kind_eq b1 b2 = match b1, b2 with | Default bk1, Default bk2 -> binding_kind_eq bk1 bk2 -| Generalized (bk1, ck1, b1), Generalized (bk2, ck2, b2) -> - binding_kind_eq bk1 bk2 && binding_kind_eq ck1 ck2 && +| Generalized (ck1, b1), Generalized (ck2, b2) -> + binding_kind_eq ck1 ck2 && (if b1 then b2 else not b2) | _ -> false diff --git a/interp/constrextern.ml b/interp/constrextern.ml index bb66658a37..701c07dc8d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -107,7 +107,7 @@ let _show_inactive_notations () = let deactivate_notation nr = match nr with | SynDefRule kn -> - (* shouldn't we check wether it is well defined? *) + (* shouldn't we check whether it is well defined? *) inactive_notations_table := IRuleSet.add nr !inactive_notations_table | NotationRule (scopt, ntn) -> match availability_of_notation (scopt, ntn) (scopt, []) with @@ -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 f06493b374..1a81dc41a1 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -389,7 +389,7 @@ let push_name_env ?(global_level=false) ntnvars implargs env = {env with ids = Id.Set.add id env.ids; impls = Id.Map.add id implargs env.impls} let intern_generalized_binder ?(global_level=false) intern_type ntnvars - env {loc;v=na} b b' t ty = + env {loc;v=na} b' t ty = let ids = (match na with Anonymous -> fun x -> x | Name na -> Id.Set.add na) env.ids in let ty, ids' = if t then ty, ids else @@ -403,7 +403,7 @@ let intern_generalized_binder ?(global_level=false) intern_type ntnvars env fvs in let bl = List.map CAst.(map (fun id -> - (Name id, b, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None)))) + (Name id, Implicit, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None)))) fvs in let na = match na with @@ -433,8 +433,8 @@ let intern_assumption intern ntnvars env nal bk ty = (push_name_env ntnvars impls env locna, (make ?loc (na,k,locate_if_hole ?loc na ty))::bl)) (env, []) nal - | Generalized (b,b',t) -> - let env, b = intern_generalized_binder intern_type ntnvars env (List.hd nal) b b' t ty in + | Generalized (b',t) -> + let env, b = intern_generalized_binder intern_type ntnvars env (List.hd nal) b' t ty in env, b let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function @@ -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) @@ -1229,7 +1221,7 @@ let add_local_defs_and_check_length loc env g pl args = match g with let maxargs = Inductiveops.constructor_nalldecls env cstr in if List.length pl' + List.length args > maxargs then error_wrong_numarg_constructor ?loc env cstr (Inductiveops.constructor_nrealargs env cstr); - (* Two possibilities: either the args are given with explict + (* Two possibilities: either the args are given with explicit variables for local definitions, then we give the explicit args extended with local defs, so that there is nothing more to be added later on; or the args are not enough to have all arguments, @@ -1467,7 +1459,7 @@ let alias_of als = match als.alias_ids with @returns a raw_case_pattern_expr : - no notations and syntactic definition - - global reference and identifeir instead of reference + - global reference and identifier instead of reference *) @@ -1642,15 +1634,13 @@ let drop_notations_pattern looked_for genv = | CPatCast (_,_) -> (* We raise an error if the pattern contains a cast, due to current restrictions on casts in patterns. Cast in patterns - are supportted only in local binders and only at top - level. In fact, they are currently eliminated by the - parser. The only reason why they are in the - [cases_pattern_expr] type is that the parser needs to factor - the "(c : t)" notation with user defined notations (such as - the pair). In the long term, we will try to support such - casts everywhere, and use them to print the domains of - lambdas in the encoding of match in constr. This check is - here and not in the parser because it would require + are supported only in local binders and only at top level. + The only reason they are in the [cases_pattern_expr] type + is that the parser needs to factor the "c : t" notation + with user defined notations. In the long term, we will try to + support such casts everywhere, and perhaps use them to print + the domains of lambdas in the encoding of match in constr. + This check is here and not in the parser because it would require duplicating the levels of the [pattern] rule. *) CErrors.user_err ?loc ~hdr:"drop_notations_pattern" (Pp.strbrk "Casts are not supported in this pattern.") diff --git a/interp/declare.ml b/interp/declare.ml index 7ee7ecb5e8..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 = { @@ -163,7 +167,8 @@ let define_constant ?role ?(export_seff=false) id cd = not de.const_entry_opaque || is_poly de -> (* This globally defines the side-effects in the environment. *) - let de, export = Global.export_private_constants ~in_section de in + let body, export = Global.export_private_constants ~in_section (Future.force de.const_entry_body) in + let de = { de with const_entry_body = Future.from_val (body, ()) } in export, ConstantEntry (PureEntry, DefinitionEntry de) | _ -> [], ConstantEntry (EffectEntry, cd) in @@ -214,11 +219,10 @@ let cache_variable ((sp,_),o) = let impl = if impl then Implicit else Explicit in impl, true, poly, ctx | SectionLocalDef (de) -> - let (de, eff) = Global.export_private_constants ~in_section:true de in - let () = List.iter register_side_effect eff in (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) - let (body, uctx), () = Future.force de.const_entry_body in + let ((body, uctx), eff) = Global.export_private_constants ~in_section:true (Future.force de.const_entry_body) in + let () = List.iter register_side_effect eff in let poly, univs = match de.const_entry_universes with | Monomorphic_entry uctx -> false, uctx | Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx @@ -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 2ffde31fc0..0b1a396a34 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -40,7 +40,7 @@ type internal_flag = | InternalTacticRequest | UserIndividualRequest -(* Defaut definition entries, transparent with no secctx or proj information *) +(* Default definition entries, transparent with no secctx or proj information *) val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool -> ?inline:bool -> ?types:types -> ?univs:Entries.universes_entry -> @@ -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/impargs.ml b/interp/impargs.ml index 806fe93297..f3cdd64633 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -96,11 +96,11 @@ let set_maximality imps b = this kind if there is enough arguments to infer them) - [DepFlex] means that the implicit argument can be found by unification - along a collapsable path only (e.g. as x in (P x) where P is another + along a collapsible path only (e.g. as x in (P x) where P is another argument) (we do (defensively) print the arguments of this kind) - [DepFlexAndRigid] means that the least argument from which the - implicit argument can be inferred is following a collapsable path + implicit argument can be inferred is following a collapsible path but there is a greater argument from where the implicit argument is inferable following a rigid path (useful to know how to print a partial application) diff --git a/interp/impargs.mli b/interp/impargs.mli index ccdd448460..1099074c63 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -34,7 +34,7 @@ val with_implicit_protection : ('a -> 'b) -> 'a -> 'b (** {6 ... } *) (** An [implicits_list] is a list of positions telling which arguments - of a reference can be automatically infered *) + of a reference can be automatically inferred *) type argument_position = @@ -50,11 +50,11 @@ type implicit_explanation = this kind if there is enough arguments to infer them) *) | DepFlex of argument_position (** means that the implicit argument can be found by unification - along a collapsable path only (e.g. as x in (P x) where P is another + along a collapsible path only (e.g. as x in (P x) where P is another argument) (we do (defensively) print the arguments of this kind) *) | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position (** means that the least argument from which the - implicit argument can be inferred is following a collapsable path + implicit argument can be inferred is following a collapsible path but there is a greater argument from where the implicit argument is inferable following a rigid path (useful to know how to print a partial application) *) diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 6277d874dd..bac46c2d2f 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -196,10 +196,9 @@ let combine_params avoid fn applied needed = user_err ?loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments") in aux [] avoid applied needed -let combine_params_freevar = - fun avoid (_, decl) -> - let id' = next_name_away_from (RelDecl.get_name decl) avoid in - (CAst.make @@ CRef (qualid_of_ident id',None), Id.Set.add id' avoid) +let combine_params_freevar avoid (_, decl) = + let id' = next_name_away_from (RelDecl.get_name decl) avoid in + (CAst.make @@ CRef (qualid_of_ident id',None), Id.Set.add id' avoid) let destClassApp cl = let open CAst in @@ -222,34 +221,34 @@ let implicit_application env ?(allow_partial=true) f ty = let is_class = try let ({CAst.v=(qid, _, _)} as clapp) = destClassAppExpl ty in - let gr = Nametab.locate qid in - if Typeclasses.is_class gr then Some (clapp, gr) else None + if Libnames.idset_mem_qualid qid env then None + else + let gr = Nametab.locate qid in + if Typeclasses.is_class gr then Some (clapp, gr) else None with Not_found -> None in - match is_class with - | None -> ty, env - | Some ({CAst.loc;v=(id, par, inst)}, gr) -> - let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in - let c, avoid = - let env = Global.env () in - let sigma = Evd.from_env env in - let c = class_info env sigma gr in - let (ci, rd) = c.cl_context in - if not allow_partial then - begin - let opt_succ x n = match x with - | None -> succ n - | Some _ -> n - in - let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in - let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in - if not (Int.equal needlen applen) then - mismatched_ctx_inst_err (Global.env ()) Typeclasses_errors.Parameters (List.map fst par) rd - end; - let pars = List.rev (List.combine ci rd) in - let args, avoid = combine_params avoid f par pars in - CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid - in c, avoid + match is_class with + | None -> ty, env + | Some ({CAst.loc;v=(id, par, inst)}, gr) -> + let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in + let env = Global.env () in + let sigma = Evd.from_env env in + let c = class_info env sigma gr in + let (ci, rd) = c.cl_context in + if not allow_partial then + begin + let opt_succ x n = match x with + | None -> succ n + | Some _ -> n + in + let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in + let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in + if not (Int.equal needlen applen) then + mismatched_ctx_inst_err (Global.env ()) Typeclasses_errors.Parameters (List.map fst par) rd + end; + let pars = List.rev (List.combine ci rd) in + let args, avoid = combine_params avoid f par pars in + CAst.make ?loc @@ CAppExpl ((None, id, inst), args), avoid let warn_ignoring_implicit_status = CWarnings.create ~name:"ignoring_implicit_status" ~category:"implicits" 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/interp/syntax_def.ml b/interp/syntax_def.ml index 49273c4146..a7e1de736c 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -48,7 +48,7 @@ let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = match onlyparse with | None -> (* Redeclare it to be used as (short) name in case an other (distfix) - notation was declared inbetween *) + notation was declared in between *) Notation.declare_uninterpretation (Notation.SynDefRule kn) pat | _ -> () end diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index 542a05fd25..a1c49bee95 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -105,7 +105,7 @@ value init_coq_vm(value unit) /* ML */ init_coq_interpreter(); /* Some predefined pointer code. - * It is typically contained in accumlator blocks whose tag is 0 and thus + * It is typically contained in accumulator blocks whose tag is 0 and thus * scanned by the GC, so make it look like an OCaml block. */ value accu_block = (value) coq_stat_alloc(2 * sizeof(value)); Hd_hp (accu_block) = Make_header (1, Abstract_tag, Caml_black); \ diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 95f88c0306..fc7d1a54f2 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -226,7 +226,7 @@ let unfold_red kn = * this constant or abstraction. * * i_tab is the cache table of the results * - * ref_value_cache searchs in the tab, otherwise uses i_repr to + * ref_value_cache searches in the tab, otherwise uses i_repr to * compute the result and store it in the table. If the constant can't * be unfolded, returns None, but does not store this failure. * This * doesn't take the RESET into account. You mustn't keep such a table @@ -645,7 +645,7 @@ and subst_constr subst c = match [@ocaml.warning "-4"] Constr.kind c with and comp_subs el s = Esubst.lift_subst (fun el c -> lazy (to_constr el c)) el s -(* This function defines the correspondance between constr and +(* This function defines the correspondence between constr and fconstr. When we find a closure whose substitution is the identity, then we directly return the constr to avoid possibly huge reallocation. *) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 1a790eaed6..60185464c5 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -200,7 +200,7 @@ val whd_val : clos_infos -> clos_tab -> fconstr -> constr val whd_stack : clos_infos -> clos_tab -> fconstr -> stack -> fconstr * stack -(** [eta_expand_ind_stack env ind c s t] computes stacks correspoding +(** [eta_expand_ind_stack env ind c s t] computes stacks corresponding to the conversion of the eta expansion of t, considered as an inhabitant of ind, and the Constructor c of this inductive type applied to arguments s. diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 69f004307d..90fbcb8ae3 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -386,7 +386,7 @@ let rec is_tailcall = function | Klabel _ :: c -> is_tailcall c | _ -> None -(* Extention of the continuation *) +(* Extension of the continuation *) (* Add a Kpop n instruction in front of a continuation *) let rec add_pop n = function diff --git a/kernel/constr.mli b/kernel/constr.mli index 7fc57cdb8a..aa5878c9d7 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -141,7 +141,7 @@ val mkRef : GlobRef.t Univ.puniverses -> constr [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] presented as describe in [ci]. - [p] stucture is [fun args x -> "return clause"] + [p] structure is [fun args x -> "return clause"] [ac]{^ ith} element is ith constructor case presented as {e lambda construct_args (without params). case_term } *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 9b6e37251f..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,28 +199,26 @@ 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 cook_constant ~hcons { from = cb; info } = + 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 let cache = RefTable.create 13 in let abstract, usubst, abs_ctx = abstract in @@ -220,13 +226,13 @@ let cook_constant ~hcons { from = cb; info } = let expmod = expmod_constr_subst cache modlist usubst in let hyps0 = Context.Named.map expmod abstract in let hyps = abstract_context hyps0 in - let map c = - let c = abstract_constant_body (expmod c) hyps in - if hcons then Constr.hcons c else c - in - let body = on_body modlist (hyps0, usubst, abs_ctx) - map - cb.const_body + let map c = abstract_constant_body (expmod c) hyps in + 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 -> @@ -251,4 +257,115 @@ let cook_constant ~hcons { 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 b022e2ac09..934b7c6b50 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -27,8 +27,11 @@ type 'opaque result = { cook_context : Constr.named_context option; } -val cook_constant : hcons:bool -> recipe -> Opaqueproof.opaque result -val cook_constr : Opaqueproof.cooking_info -> constr -> constr +val cook_constant : recipe -> Opaqueproof.opaque result +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/declarations.ml b/kernel/declarations.ml index 36ee952099..388b4f14bf 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -22,11 +22,11 @@ type engagement = set_predicativity (** {6 Representation of constants (Definition/Axiom) } *) (** Non-universe polymorphic mode polymorphism (Coq 8.2+): inductives - and constants hiding inductives are implicitely polymorphic when + and constants hiding inductives are implicitly polymorphic when applied to parameters, on the universes appearing in the whnf of their parameters and their conclusion, in a template style. - In truely universe polymorphic mode, we always use RegularArity. + In truly universe polymorphic mode, we always use RegularArity. *) type template_arity = { @@ -165,7 +165,7 @@ type one_inductive_body = { mind_nrealdecls : int; (** Length of realargs context (with let, no params) *) - mind_kelim : Sorts.family list; (** List of allowed elimination sorts *) + mind_kelim : Sorts.family; (** Highest allowed elimination sort *) mind_nf_lc : (rel_context * types) array; (** Head normalized constructor types so that their conclusion exposes the inductive type *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 05f342a82a..c47bde0864 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -483,16 +483,6 @@ let constant_value_and_type env (kn, u) = in b', subst_instance_constr u cb.const_type, cst -let body_of_constant_body env cb = - let otab = opaque_tables env in - match cb.const_body with - | Undef _ | Primitive _ -> - None - | Def c -> - Some (Mod_subst.force_constr c, Declareops.constant_polymorphic_context cb) - | OpaqueDef o -> - Some (Opaqueproof.force_proof otab o, Declareops.constant_polymorphic_context cb) - (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant application. *) diff --git a/kernel/environ.mli b/kernel/environ.mli index f6cd41861e..2abcea148a 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -215,12 +215,6 @@ val constant_value_and_type : env -> Constant.t puniverses -> polymorphic *) val constant_context : env -> Constant.t -> Univ.AUContext.t -(** Returns the body of the constant if it has any, and the polymorphic context - it lives in. For monomorphic constant, the latter is empty, and for - polymorphic constants, the term contains De Bruijn universe variables that - need to be instantiated. *) -val body_of_constant_body : env -> Opaqueproof.opaque constant_body -> (Constr.constr * Univ.AUContext.t) option - (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant application. *) diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index 4e6e595331..65298938fa 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -232,18 +232,9 @@ let check_record data = (* - all_sorts in case of small, unitary Prop (not smashed) *) (* - logical_sorts in case of large, unitary Prop (smashed) *) -let all_sorts = [InSProp;InProp;InSet;InType] -let small_sorts = [InSProp;InProp;InSet] -let logical_sorts = [InSProp;InProp] -let sprop_sorts = [InSProp] - let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_;ind_has_relevant_arg=_} = - if not ind_squashed then all_sorts - else match Sorts.family (Sorts.sort_of_univ ind_univ) with - | InType -> assert false - | InSet -> small_sorts - | InProp -> logical_sorts - | InSProp -> sprop_sorts + if not ind_squashed then InType + else Sorts.family (Sorts.sort_of_univ ind_univ) (* Returns the list [x_1, ..., x_n] of levels contributing to template polymorphism. The elements x_k is None if the k-th parameter (starting diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index ad51af66a2..ef2c30b76a 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -22,7 +22,7 @@ open Declarations - for each inductive, (arity * constructors) (with params) * (indices * splayed constructor types) (both without params) - * allowed eliminations + * top allowed elimination *) val typecheck_inductive : env -> mutual_inductive_entry -> env @@ -31,5 +31,5 @@ val typecheck_inductive : env -> mutual_inductive_entry -> * Constr.rel_context * ((inductive_arity * Constr.types array) * (Constr.rel_context * (Constr.rel_context * Constr.types) array) * - Sorts.family list) + Sorts.family) array diff --git a/kernel/inductive.ml b/kernel/inductive.ml index d9335d39b5..beff8f4421 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -166,7 +166,7 @@ let make_subst env = (* template, it is identity substitution otherwise (ie. when u is *) (* already in the domain of the substitution) [remember_subst] will *) (* update its image [x] by [sup x u] in order not to forget the *) - (* dependency in [u] that remains to be fullfilled. *) + (* dependency in [u] that remains to be fulfilled. *) make (remember_subst u subst) (sign, exp, []) | _sign, [], _ -> (* Uniform parameters are exhausted *) @@ -289,7 +289,7 @@ let get_instantiated_arity (_ind,u) (mib,mip) params = let sign, s = mind_arity mip in full_inductive_instantiate mib u params sign, s -let elim_sorts (_,mip) = mip.mind_kelim +let elim_sort (_,mip) = mip.mind_kelim let is_private (mib,_) = mib.mind_private = Some true let is_primitive_record (mib,_) = @@ -305,12 +305,12 @@ let build_dependent_inductive ind (_,mip) params = @ Context.Rel.to_extended_list mkRel 0 realargs) (* This exception is local *) -exception LocalArity of (Sorts.family list * Sorts.family * Sorts.family * arity_error) option +exception LocalArity of (Sorts.family * Sorts.family * Sorts.family * arity_error) option let check_allowed_sort ksort specif = - if not (CList.exists (Sorts.family_equal ksort) (elim_sorts specif)) then + if not (Sorts.family_leq ksort (elim_sort specif)) then let s = inductive_sort_family (snd specif) in - raise (LocalArity (Some(elim_sorts specif, ksort,s,error_elim_explain ksort s))) + raise (LocalArity (Some(elim_sort specif, ksort,s,error_elim_explain ksort s))) let is_correct_arity env c pj ind specif params = let arsign,_ = get_instantiated_arity ind specif params in diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 997a620742..f705cdf646 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -52,7 +52,7 @@ val type_of_inductive : env -> mind_specif puniverses -> types val type_of_inductive_knowing_parameters : env -> ?polyprop:bool -> mind_specif puniverses -> types Lazy.t array -> types -val elim_sorts : mind_specif -> Sorts.family list +val elim_sort : mind_specif -> Sorts.family val is_private : mind_specif -> bool val is_primitive_record : mind_specif -> bool diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 2de5faa6df..72393d0081 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -188,7 +188,7 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = in let new_equiv = add_delta_resolver equiv new_mb.mod_delta in (* we propagate the new equality in the rest of the signature - with the identity substitution accompagned by the new resolver*) + with the identity substitution accompanied by the new resolver*) let id_subst = map_mp mp' mp' new_mb.mod_delta in let new_after = subst_structure id_subst after in before@(lab,SFBmodule new_mb')::new_after, new_equiv, cst diff --git a/kernel/modops.ml b/kernel/modops.ml index 4fdd7ab334..472fddb829 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -515,7 +515,7 @@ and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = "Module M:=P." or "Module M. Include P. End M." We need to perform two operations to compute the body of M. - The first one is applying the substitution {P <- M} on the type of P - - The second one is strenghtening. *) + - The second one is strengthening. *) let strengthen_and_subst_mb mb mp include_b = match mb.mod_type with |NoFunctor struc -> diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 18c1bcc0f8..e18b726111 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -16,15 +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; +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 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 *) @@ -36,35 +43,28 @@ let empty_opaquetab = { opaque_dir = DirPath.initial; } -(* hooks *) -let default_get_opaque dp _ = - CErrors.user_err Pp.(pr_sequence str ["Cannot access opaque proofs in library"; DirPath.to_string dp]) -let default_get_univ dp _ = - CErrors.user_err (Pp.pr_sequence Pp.str [ - "Cannot access universe constraints of opaque proofs in library "; - DirPath.to_string dp]) - -let get_opaque = ref default_get_opaque -let get_univ = ref default_get_univ +let not_here () = + CErrors.user_err Pp.(str "Cannot access opaque delayed proof") -let set_indirect_opaque_accessor f = (get_opaque := f) -let set_indirect_univ_accessor f = (get_univ := f) -(* /hooks *) - -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) -> - (** Uncomment to check dynamically that all terms turned into - indirections are hashconsed. *) -(* let check_hcons c = let c' = hcons_constr c in assert (c' == c); c in *) -(* let cu = Future.chain ~pure:true cu (fun (c, u) -> check_hcons c; c, u) in *) + | 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. *) + let hcons (c, u) = + let c = Constr.hcons c in + let u = Univ.hcons_universe_context_set u in + (c, u) + 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 @@ -77,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) @@ -89,57 +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 { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> - fst(Future.force cu) +let force_proof access { opaque_val = prfs; opaque_dir = odp; _ } = function + | 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 - else !get_opaque dp i in - let c = Future.force pt in + 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 -> v + in force_constr (List.fold_right subst_substituted l (from_val c)) -let force_constraints { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> snd(Future.force cu) +let force_constraints _access { opaque_val = prfs; opaque_dir = odp; _ } = function + | Direct (_,_,cu) -> + snd(Future.force cu) | Indirect (_,dp,i) -> if DirPath.equal dp odp - then snd (Future.force (snd (Int.Map.find i prfs))) - else match !get_univ dp i with - | None -> Univ.ContextSet.empty - | Some u -> Future.force u + then + let (_, _, cu) = Int.Map.find i prfs in + snd (Future.force cu) + else Univ.ContextSet.empty -let get_constraints { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> Some(Future.chain cu snd) - | Indirect (_,dp,i) -> - if DirPath.equal dp odp - then Some(Future.chain (snd (Int.Map.find i prfs)) snd) - else !get_univ dp i +let get_direct_constraints = function +| Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") +| Direct (_, _, cu) -> Future.chain cu snd module FMap = Future.UUIDMap -let a_constr = Future.from_val (mkRel 1) -let a_univ = Future.from_val Univ.ContextSet.empty -let a_discharge : cooking_info list = [] - -let dump { opaque_val = otab; opaque_len = n; _ } = - let opaque_table = Array.make n a_constr in - let univ_table = Array.make n a_univ in - let disch_table = Array.make n a_discharge in +let dump ?(except = Future.UUIDSet.empty) { opaque_val = otab; opaque_len = n; _ } = + let opaque_table = Array.make n ([], 0, None) in let f2t_map = ref FMap.empty in - Int.Map.iter (fun n (d,cu) -> - let c, u = Future.split2 cu in - Future.sink u; - Future.sink c; - opaque_table.(n) <- c; - univ_table.(n) <- u; - disch_table.(n) <- d; - f2t_map := FMap.add (Future.uuid cu) n !f2t_map) - otab; - opaque_table, univ_table, disch_table, !f2t_map + let iter n (univs, d, cu) = + let uid = Future.uuid cu in + let () = f2t_map := FMap.add (Future.uuid cu) n !f2t_map in + 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, !f2t_map diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 4e8956af06..6e275649cd 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -28,53 +28,42 @@ 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 -(** From a [opaque] back to a [constr]. This might use the - indirect opaque accessor configured below. *) -val force_proof : opaquetab -> opaque -> constr -val force_constraints : opaquetab -> opaque -> Univ.ContextSet.t -val get_constraints : - opaquetab -> opaque -> Univ.ContextSet.t Future.computation option - -val subst_opaque : substitution -> opaque -> opaque - -type work_list = (Univ.Instance.t * Id.t array) Cmap.t * +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; +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 +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 + this indirect storage, by telling how to retrieve terms. +*) -val join_opaque : ?except:Future.UUIDSet.t -> opaquetab -> opaque -> unit +(** From a [opaque] back to a [constr]. This might use the + indirect opaque accessor given as an argument. *) +val force_proof : indirect_accessor -> opaquetab -> opaque -> constr +val force_constraints : indirect_accessor -> opaquetab -> opaque -> Univ.ContextSet.t +val get_direct_constraints : opaque -> Univ.ContextSet.t Future.computation -val dump : opaquetab -> - Constr.t Future.computation array * - Univ.ContextSet.t Future.computation array * - cooking_info list array * - int Future.UUIDMap.t +val subst_opaque : substitution -> opaque -> opaque -(** When stored indirectly, opaque terms are indexed by their library - dirpath and an integer index. The following two functions activate - this indirect storage, by telling how to store and retrieve terms. - Default creator always returns [None], preventing the creation of - any indirect link, and default accessor always raises an error. -*) +val discharge_direct_opaque : + cooking_info -> opaque -> opaque -val set_indirect_opaque_accessor : - (DirPath.t -> int -> constr Future.computation) -> unit -val set_indirect_univ_accessor : - (DirPath.t -> int -> Univ.ContextSet.t Future.computation option) -> unit +val join_opaque : ?except:Future.UUIDSet.t -> opaquetab -> opaque -> unit +val dump : ?except:Future.UUIDSet.t -> opaquetab -> + (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 a5d8a480ee..759cbe22ee 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -458,19 +458,11 @@ let labels_of_mib mib = Array.iter visit_mip mib.mind_packets; get () -let globalize_constant_universes env cb = +let globalize_constant_universes cb = match cb.const_universes with | Monomorphic cstrs -> - Now (false, cstrs) :: - (match cb.const_body with - | (Undef _ | Def _ | Primitive _) -> [] - | OpaqueDef lc -> - match Opaqueproof.get_constraints (Environ.opaque_tables env) lc with - | None -> [] - | Some fc -> - match Future.peek_val fc with - | None -> [Later fc] - | Some c -> [Now (false, c)]) + (* Constraints hidden in the opaque body are added by [add_constant_aux] *) + [Now (false, cstrs)] | Polymorphic _ -> [Now (true, Univ.ContextSet.empty)] @@ -480,9 +472,9 @@ let globalize_mind_universes mb = [Now (false, ctx)] | Polymorphic _ -> [Now (true, Univ.ContextSet.empty)] -let constraints_of_sfb env sfb = +let constraints_of_sfb sfb = match sfb with - | SFBconst cb -> globalize_constant_universes env cb + | SFBconst cb -> globalize_constant_universes cb | SFBmind mib -> globalize_mind_universes mib | SFBmodtype mtb -> [Now (false, mtb.mod_constraints)] | SFBmodule mb -> [Now (false, mb.mod_constraints)] @@ -520,7 +512,8 @@ let add_field ?(is_include=false) ((l,sfb) as field) gn senv = separately. *) senv else - let cst = constraints_of_sfb senv.env sfb in + (* Delayed constraints from opaque body are added by [add_constant_aux] *) + let cst = constraints_of_sfb sfb in add_constraints_list cst senv in let env' = match sfb, gn with @@ -553,6 +546,17 @@ type exported_private_constant = let add_constant_aux ~in_section senv (kn, cb) = let l = Constant.label kn in + let delayed_cst = match cb.const_body with + | OpaqueDef o when not (Declareops.constant_is_polymorphic cb) -> + let fc = Opaqueproof.get_direct_constraints o in + begin match Future.peek_val fc with + | None -> [Later fc] + | Some c -> [Now (false, c)] + end + | Undef _ | Def _ | Primitive _ | OpaqueDef _ -> [] + in + (* This is the only place where we hashcons the contents of a constant body *) + let cb = if in_section then cb else Declareops.hcons_const_body cb in let cb, otab = match cb.const_body with | OpaqueDef lc when not in_section -> (* In coqc, opaque constants outside sections will be stored @@ -565,6 +569,7 @@ let add_constant_aux ~in_section senv (kn, cb) = in let senv = { senv with env = Environ.set_opaque_tables senv.env otab } in let senv' = add_field (l,SFBconst cb) (C kn) senv in + let senv' = add_constraints_list delayed_cst senv' in let senv'' = match cb.const_body with | Undef (Some lev) -> update_resolver @@ -645,18 +650,10 @@ let inline_side_effects env body side_eff = let body = List.fold_right fold_arg args body in (body, ctx, sigs) -let inline_private_constants_in_definition_entry env ce = - let open Entries in - { ce with - const_entry_body = Future.chain - ce.const_entry_body (fun ((body, ctx), side_eff) -> - let body, ctx',_ = inline_side_effects env body side_eff in - let ctx' = Univ.ContextSet.union ctx ctx' in - (body, ctx'), ()); - } - -let inline_private_constants_in_constr env body side_eff = - pi1 (inline_side_effects env body side_eff) +let inline_private_constants env ((body, ctx), side_eff) = + let body, ctx',_ = inline_side_effects env body side_eff in + let ctx' = Univ.ContextSet.union ctx ctx' in + (body, ctx') let is_suffix l suf = match l with | [] -> false @@ -709,13 +706,7 @@ let constant_entry_of_side_effect eff = let export_eff eff = (eff.seff_constant, eff.seff_body, eff.seff_role) -let export_side_effects mb env c = - let open Entries in - let body = c.const_entry_body in - let _, eff = Future.force body in - let ce = { c with - Entries.const_entry_body = Future.chain body - (fun (b_ctx, _) -> b_ctx, ()) } in +let export_side_effects mb env (b_ctx, eff) = let not_exists e = try ignore(Environ.lookup_constant e.seff_constant env); false with Not_found -> true in @@ -739,7 +730,7 @@ let export_side_effects mb env c = in let rec translate_seff sl seff acc env = match seff with - | [] -> List.rev acc, ce + | [] -> List.rev acc, b_ctx | eff :: rest -> if Int.equal sl 0 then let env, cb = @@ -758,9 +749,13 @@ let export_side_effects mb env c = 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)) 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 @@ -768,8 +763,7 @@ let export_private_constants ~in_section ce senv = let add_recipe ~in_section l r senv = let kn = Constant.make2 senv.modpath l in - let cb = Term_typing.translate_recipe ~hcons:(not in_section) senv.env kn r in - let cb = if in_section then cb else Declareops.hcons_const_body cb in + let cb = Term_typing.translate_recipe senv.env kn r in let senv = add_constant_aux ~in_section senv (kn, cb) in kn, senv @@ -788,7 +782,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 diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 36ca3d8c47..770caf5406 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -49,10 +49,8 @@ val concat_private : private_constants -> private_constants -> private_constants [e1] must be more recent than those of [e2]. *) val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output -val inline_private_constants_in_constr : - Environ.env -> Constr.constr -> private_constants -> Constr.constr -val inline_private_constants_in_definition_entry : - Environ.env -> private_constants Entries.definition_entry -> unit Entries.definition_entry +val inline_private_constants : + Environ.env -> private_constants Entries.proof_output -> Constr.constr Univ.in_universe_context_set val push_private_constants : Environ.env -> private_constants -> Environ.env (** Push the constants in the environment if not already there. *) @@ -93,8 +91,8 @@ type exported_private_constant = Constant.t * Entries.side_effect_role val export_private_constants : in_section:bool -> - private_constants Entries.definition_entry -> - (unit Entries.definition_entry * exported_private_constant list) safe_transformer + private_constants Entries.proof_output -> + (Constr.constr Univ.in_universe_context_set * exported_private_constant list) safe_transformer (** returns the main constant plus a list of auxiliary constants (empty unless one requires the side effects to be exported) *) diff --git a/kernel/sorts.ml b/kernel/sorts.ml index 09c98ca1bc..b5a929697e 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -91,6 +91,8 @@ let family_compare a b = match a,b with let family_equal = (==) +let family_leq a b = family_compare a b <= 0 + open Hashset.Combine let hash = function @@ -101,11 +103,6 @@ let hash = function let h = Univ.Universe.hash u in combinesmall 2 h -module List = struct - let mem = List.memq - let intersect l l' = CList.intersect family_equal l l' -end - module Hsorts = Hashcons.Make( struct diff --git a/kernel/sorts.mli b/kernel/sorts.mli index c49728b146..3769e31465 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -37,11 +37,7 @@ val hcons : t -> t val family_compare : family -> family -> int val family_equal : family -> family -> bool - -module List : sig - val mem : family -> family list -> bool - val intersect : family list -> family list -> family list -end +val family_leq : family -> family -> bool val univ_of_sort : t -> Univ.Universe.t val sort_of_univ : Univ.Universe.t -> t diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 74c6189a65..f984088f47 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -74,7 +74,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = let j = Typeops.infer env t in let usubst, univs = Declareops.abstract_universes uctx in let r = Typeops.assumption_of_judgment env j in - let t = Constr.hcons (Vars.subst_univs_level_constr usubst j.uj_val) in + let t = Vars.subst_univs_level_constr usubst j.uj_val in { Cooking.cook_body = Undef nl; cook_type = t; @@ -95,7 +95,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = | Some typ -> let typ = Typeops.infer_type env typ in Typeops.check_primitive_type env op_t typ.utj_val; - Constr.hcons typ.utj_val + typ.utj_val | None -> match op_t with | CPrimitives.OT_op op -> Typeops.type_of_prim env op @@ -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) -> @@ -151,7 +143,7 @@ the polymorphic case let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in j, uctx in - let c = Constr.hcons j.uj_val in + let c = j.uj_val in feedback_completion_typecheck feedback_id; c, uctx) in let def = OpaqueDef proofterm in @@ -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 @@ -205,11 +237,8 @@ the polymorphic case let _ = Typeops.judge_of_cast env j DEFAULTcast tj in Vars.subst_univs_level_constr usubst tj.utj_val in - let def = Constr.hcons (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 = Vars.subst_univs_level_constr usubst j.uj_val in + let def = Def (Mod_subst.from_val def) in feedback_completion_typecheck feedback_id; { Cooking.cook_body = def; @@ -328,9 +357,9 @@ let translate_local_assum env t = let t = Typeops.assumption_of_judgment env j in j.uj_val, t -let translate_recipe ~hcons env _kn r = +let translate_recipe env _kn r = let open Cooking in - let result = Cooking.cook_constant ~hcons r in + let result = Cooking.cook_constant r in let univs = result.cook_universes in let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs result.cook_body in let tps = Option.map Cemitcodes.from_val res in diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 592a97e132..fd0f2a18e4 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -35,7 +35,7 @@ val translate_constant : 'a trust -> env -> Constant.t -> 'a constant_entry -> Opaqueproof.proofterm constant_body -val translate_recipe : hcons:bool -> env -> Constant.t -> Cooking.recipe -> Opaqueproof.opaque constant_body +val translate_recipe : env -> Constant.t -> Cooking.recipe -> Opaqueproof.opaque constant_body (** Internal functions, mentioned here for debug purpose only *) diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index c45fe1cf00..857e4fabf7 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -49,7 +49,7 @@ type ('constr, 'types) ptype_error = | BadAssumption of ('constr, 'types) punsafe_judgment | ReferenceVariables of Id.t * 'constr | ElimArity of pinductive * 'constr * ('constr, 'types) punsafe_judgment - * (Sorts.family list * Sorts.family * Sorts.family * arity_error) option + * (Sorts.family * Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 88165a4f07..8e25236851 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -50,7 +50,7 @@ type ('constr, 'types) ptype_error = | BadAssumption of ('constr, 'types) punsafe_judgment | ReferenceVariables of Id.t * 'constr | ElimArity of pinductive * 'constr * ('constr, 'types) punsafe_judgment - * (Sorts.family list * Sorts.family * Sorts.family * arity_error) option + * (Sorts.family * Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int @@ -104,7 +104,7 @@ val error_reference_variables : env -> Id.t -> constr -> 'a val error_elim_arity : env -> pinductive -> constr -> unsafe_judgment -> - (Sorts.family list * Sorts.family * Sorts.family * arity_error) option -> 'a + (Sorts.family * Sorts.family * Sorts.family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a diff --git a/kernel/uint63.mli b/kernel/uint63.mli index f25f24512d..93632da110 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -13,7 +13,7 @@ val of_uint : int -> t val hash : t -> int - (* convertion to a string *) + (* conversion to a string *) val to_string : t -> string val of_string : string -> t diff --git a/kernel/univ.ml b/kernel/univ.ml index b1bbc25fe6..2b88d6884d 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -726,7 +726,7 @@ let univ_level_rem u v min = | Some u' -> if Level.equal u u' then min else v | None -> List.filter (fun (l, n) -> not (Int.equal n 0 && Level.equal u l)) v -(* Is u mentionned in v (or equals to v) ? *) +(* Is u mentioned in v (or equals to v) ? *) (**********************************************************************) diff --git a/kernel/univ.mli b/kernel/univ.mli index db178c4bb0..ddb204dd52 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -163,7 +163,7 @@ val super : Universe.t -> Universe.t val universe_level : Universe.t -> Level.t option -(** [univ_level_mem l u] Is l is mentionned in u ? *) +(** [univ_level_mem l u] Is l is mentioned in u ? *) val univ_level_mem : Level.t -> Universe.t -> bool diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 777a207013..88fcb71e77 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -11,10 +11,10 @@ open Names open Univ open Constr -(*******************************************) -(* Initalization of the abstract machine ***) -(* Necessary for [relaccu_tbl] *) -(*******************************************) +(********************************************) +(* Initialization of the abstract machine ***) +(* Necessary for [relaccu_tbl] *) +(********************************************) external init_vm : unit -> unit = "init_coq_vm" diff --git a/lib/cProfile.mli b/lib/cProfile.mli index 764faf8d1a..00babe1a47 100644 --- a/lib/cProfile.mli +++ b/lib/cProfile.mli @@ -18,7 +18,7 @@ To trace a function "f" you first need to get a key for it by using : let fkey = declare_profile "f";; -(the string is used to print the profile infomation). Warning: this +(the string is used to print the profile information). Warning: this function does a side effect. Choose the ident you want instead "fkey". Then if the function has ONE argument add the following just after diff --git a/lib/envars.mli b/lib/envars.mli index ebf86d0650..558fe74042 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -38,7 +38,7 @@ val datadir : unit -> string (** [configdir] is the path to the installed config directory. *) val configdir : unit -> string -(** [set_coqlib] must be runned once before any access to [coqlib] *) +(** [set_coqlib] must be run once before any access to [coqlib] *) val set_coqlib : fail:(string -> string) -> unit (** [set_user_coqlib path] sets the coqlib directory explicitedly. *) diff --git a/lib/feedback.mli b/lib/feedback.mli index f407e2fd5b..c9e6ca1266 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -56,7 +56,7 @@ type feedback = { (** {6 Feedback sent, even asynchronously, to the user interface} *) -(* The interpreter assignes an state_id to the ast, and feedbacks happening +(* The interpreter assigns a state_id to the ast, and feedbacks happening * during interpretation are attached to it. *) diff --git a/lib/flags.mli b/lib/flags.mli index a70a23b902..535b46950e 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -64,7 +64,7 @@ val beautify : bool ref val beautify_file : bool ref (* Coq quiet mode. Note that normal mode is called "verbose" here, - whereas [quiet] supresses normal output such as goals in coqtop *) + whereas [quiet] suppresses normal output such as goals in coqtop *) val quiet : bool ref val silently : ('a -> 'b) -> 'a -> 'b val verbosely : ('a -> 'b) -> 'a -> 'b diff --git a/lib/pp.mli b/lib/pp.mli index 4ce6a535c8..bc20a66824 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -18,7 +18,7 @@ (* to interpret. *) (* *) (* The datatype has a public view to allow serialization or advanced *) -(* uses, however regular users are _strongly_ warned againt its use, *) +(* uses, however regular users are _strongly_ warned against its use, *) (* they should instead rely on the available functions below. *) (* *) (* Box order and number is indeed an important factor. Try to create *) diff --git a/lib/pp_diff.mli b/lib/pp_diff.mli index 03468271d2..0eec18bd5a 100644 --- a/lib/pp_diff.mli +++ b/lib/pp_diff.mli @@ -88,7 +88,7 @@ Ppcmd_strings will be split into multiple Ppcmd_strings if a diff starts or ends in the middle of the string. Whitespace just before or just after a diff will not be part of the highlight. -Prexisting tags in pp may contain only a single Ppcmd_string. Those tags will be +Preexisting tags in pp may contain only a single Ppcmd_string. Those tags will be placed inside the diff tags to ensure proper nesting of tags within spans of "start.diff.*" ... "end.diff.*". diff --git a/lib/spawn.mli b/lib/spawn.mli index 944aa27a7f..24bbded4f1 100644 --- a/lib/spawn.mli +++ b/lib/spawn.mli @@ -9,7 +9,7 @@ (************************************************************************) (* This module implements spawning/killing managed processes with a - * synchronous or asynchronous comunication channel that works with + * synchronous or asynchronous communication channel that works with * threads or with a glib like main loop model. * * This module requires no threads and no main loop model. It takes care diff --git a/lib/util.ml b/lib/util.ml index 38d73d3453..6e8b8de5dc 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -14,7 +14,7 @@ let on_fst f (a,b) = (f a,b) let on_snd f (a,b) = (a,f b) let map_pair f (a,b) = (f a,f b) -(* Mapping under pairs *) +(* Mapping under triplets *) let on_pi1 f (a,b,c) = (f a,b,c) let on_pi2 f (a,b,c) = (a,f b,c) diff --git a/lib/util.mli b/lib/util.mli index 1eb60f509a..9a00ee3440 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -17,7 +17,7 @@ val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b val map_pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b -(** Mapping under triple *) +(** Mapping under triplets *) val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd val on_pi2 : ('a -> 'b) -> 'c * 'a * 'd -> 'c * 'b * 'd diff --git a/library/declaremods.ml b/library/declaremods.ml index 5fd11e187a..d74bdd484c 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -51,7 +51,7 @@ let inl2intopt = function - Then comes either the object segment itself (for interactive modules), or a compact way to store derived objects (path to - a earlier module + subtitution). + a earlier module + substitution). *) type algebraic_objects = diff --git a/library/global.ml b/library/global.ml index 58e2380440..d5ffae7716 100644 --- a/library/global.ml +++ b/library/global.ml @@ -132,9 +132,20 @@ let exists_objlabel id = Safe_typing.exists_objlabel id (safe_env ()) let opaque_tables () = Environ.opaque_tables (env ()) -let body_of_constant_body ce = body_of_constant_body (env ()) ce - -let body_of_constant cst = body_of_constant_body (lookup_constant cst) +let body_of_constant_body access env cb = + let open Declarations in + let otab = Environ.opaque_tables env in + match cb.const_body with + | Undef _ | Primitive _ -> + None + | Def c -> + Some (Mod_subst.force_constr c, Declareops.constant_polymorphic_context cb) + | OpaqueDef o -> + Some (Opaqueproof.force_proof access otab o, Declareops.constant_polymorphic_context cb) + +let body_of_constant_body access ce = body_of_constant_body access (env ()) ce + +let body_of_constant access cst = body_of_constant_body access (lookup_constant cst) (** Operations on kernel names *) diff --git a/library/global.mli b/library/global.mli index 984d8c666c..eaa76c3117 100644 --- a/library/global.mli +++ b/library/global.mli @@ -42,8 +42,8 @@ val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set val push_named_def : (Id.t * Entries.section_def_entry) -> unit val export_private_constants : in_section:bool -> - Safe_typing.private_constants Entries.definition_entry -> - unit Entries.definition_entry * Safe_typing.exported_private_constant list + Safe_typing.private_constants Entries.proof_output -> + Constr.constr Univ.in_universe_context_set * Safe_typing.exported_private_constant list val add_constant : ?role:Entries.side_effect_role -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * Safe_typing.private_constants @@ -100,13 +100,13 @@ val mind_of_delta_kn : KerName.t -> MutInd.t val opaque_tables : unit -> Opaqueproof.opaquetab -val body_of_constant : Constant.t -> (Constr.constr * Univ.AUContext.t) option +val body_of_constant : Opaqueproof.indirect_accessor -> Constant.t -> (Constr.constr * Univ.AUContext.t) option (** Returns the body of the constant if it has any, and the polymorphic context it lives in. For monomorphic constant, the latter is empty, and for polymorphic constants, the term contains De Bruijn universe variables that need to be instantiated. *) -val body_of_constant_body : Opaqueproof.opaque Declarations.constant_body -> (Constr.constr * Univ.AUContext.t) option +val body_of_constant_body : Opaqueproof.indirect_accessor -> Opaqueproof.opaque Declarations.constant_body -> (Constr.constr * Univ.AUContext.t) option (** Same as {!body_of_constant} but on {!Declarations.constant_body}. *) (** {6 Compiled libraries } *) 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/libnames.ml b/library/libnames.ml index 87c4de42e8..41b38e0378 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -162,6 +162,9 @@ let qualid_basename qid = let qualid_path qid = qid.CAst.v.dirpath +let idset_mem_qualid qid s = + qualid_is_ident qid && Id.Set.mem (qualid_basename qid) s + (* Default paths *) let default_library = Names.DirPath.initial (* = ["Top"] *) diff --git a/library/libnames.mli b/library/libnames.mli index bbb4d2a058..7d77d95991 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -88,6 +88,9 @@ val qualid_is_ident : qualid -> bool val qualid_path : qualid -> DirPath.t val qualid_basename : qualid -> Id.t +val idset_mem_qualid : qualid -> Id.Set.t -> bool +(** false when the qualid is not an ident *) + (** {6 ... } *) (** some preset paths *) diff --git a/library/library.ml b/library/library.ml index 500e77f89b..1ac75d2fdc 100644 --- a/library/library.ml +++ b/library/library.ml @@ -208,7 +208,7 @@ let register_open_library export m = let open_library export explicit_libs m = if (* Only libraries indirectly to open are not reopen *) - (* Libraries explicitly mentionned by the user are always reopen *) + (* Libraries explicitly mentioned by the user are always reopen *) List.exists (fun m' -> DirPath.equal m m') explicit_libs || not (library_is_opened m) then begin @@ -264,90 +264,11 @@ let in_import_library : DirPath.t list * bool -> obj = subst_function = subst_import_library; classify_function = classify_import_library } - -(************************************************************************) -(*s Locate absolute or partially qualified library names in the path *) - -exception LibUnmappedDir -exception LibNotFound -type library_location = LibLoaded | LibInPath - -let warn_several_object_files = - CWarnings.create ~name:"several-object-files" ~category:"require" - (fun (vi, vo) -> str"Loading" ++ spc () ++ str vi ++ - strbrk " instead of " ++ str vo ++ - strbrk " because it is more recent") - -let locate_absolute_library dir = - (* Search in loadpath *) - let pref, base = split_dirpath dir in - let loadpath = Loadpath.filter_path (fun dir -> DirPath.equal dir pref) in - let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in - let loadpath = List.map fst loadpath in - let find ext = - try - let name = Id.to_string base ^ ext in - let _, file = System.where_in_path ~warn:false loadpath name in - Some file - with Not_found -> None in - match find ".vo", find ".vio" with - | None, None -> raise LibNotFound - | Some file, None | None, Some file -> file - | Some vo, Some vi when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> - warn_several_object_files (vi, vo); - vi - | Some vo, Some _ -> vo - -let locate_qualified_library ?root ?(warn = true) qid = - (* Search library in loadpath *) - let dir, base = repr_qualid qid in - let loadpath = Loadpath.expand_path ?root dir in - let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in - let find ext = - try - let name = Id.to_string base ^ ext in - let lpath, file = - System.where_in_path ~warn (List.map fst loadpath) name in - Some (lpath, file) - with Not_found -> None in - let lpath, file = - match find ".vo", find ".vio" with - | None, None -> raise LibNotFound - | Some res, None | None, Some res -> res - | Some (_, vo), Some (_, vi as resvi) - when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> - warn_several_object_files (vi, vo); - resvi - | Some resvo, Some _ -> resvo - in - let dir = add_dirpath_suffix (String.List.assoc lpath loadpath) base in - (* Look if loaded *) - if library_is_loaded dir then (LibLoaded, dir,library_full_filename dir) - (* Otherwise, look for it in the file system *) - else (LibInPath, dir, file) - -let error_unmapped_dir qid = - let prefix, _ = repr_qualid qid in - user_err ~hdr:"load_absolute_library_from" - (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ - str "no physical path bound to" ++ spc () ++ DirPath.print prefix ++ fnl ()) - -let error_lib_not_found qid = - user_err ~hdr:"load_absolute_library_from" - (str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath") - -let try_locate_absolute_library dir = - try - locate_absolute_library dir - with - | LibUnmappedDir -> error_unmapped_dir (qualid_of_dirpath dir) - | LibNotFound -> error_lib_not_found (qualid_of_dirpath dir) - (************************************************************************) (** {6 Tables of opaque proof terms} *) (** We now store opaque proof terms apart from the rest of the environment. - See the [Indirect] contructor in [Lazyconstr.lazy_constr]. This way, + See the [Indirect] constructor in [Lazyconstr.lazy_constr]. This way, we can quickly load a first half of a .vo file without these opaque terms, and access them only when a specific command (e.g. Print or Print Assumptions) needs it. *) @@ -355,18 +276,14 @@ let try_locate_absolute_library dir = (** Delayed / available tables of opaque terms *) type 'a table_status = - | ToFetch of 'a Future.computation array delayed - | Fetched of 'a Future.computation array + | ToFetch of 'a array delayed + | Fetched of 'a array let opaque_tables = - ref (LibraryMap.empty : (Constr.constr table_status) LibraryMap.t) -let univ_tables = - ref (LibraryMap.empty : (Univ.ContextSet.t 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 -let add_univ_table dp st = - univ_tables := LibraryMap.add dp st !univ_tables let access_table what tables dp i = let t = match LibraryMap.find dp !tables with @@ -389,17 +306,15 @@ 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 access_univ_table dp i = - try - let what = "universe contexts of opaque proofs" in - Some (access_table what univ_tables dp i) - with Not_found -> None - -let () = - Opaqueproof.set_indirect_opaque_accessor access_opaque_table; - Opaqueproof.set_indirect_univ_accessor access_univ_table + 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; +} (************************************************************************) (* Internalise libraries *) @@ -407,9 +322,8 @@ let () = type seg_sum = summary_disk type seg_lib = library_disk type seg_univ = (* true = vivo, false = vi *) - Univ.ContextSet.t Future.computation array * Univ.ContextSet.t * bool -type seg_discharge = Opaqueproof.cooking_info list array -type seg_proofs = Constr.constr Future.computation array + Univ.ContextSet.t * bool +type seg_proofs = (Opaqueproof.cooking_info list * int * Constr.t option) array let mk_library sd md digests univs = { @@ -433,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; @@ -441,16 +354,14 @@ let intern_from_file f = let open Safe_typing in match univs with | None -> mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty - | Some (utab,uall,true) -> - add_univ_table lsd.md_name (Fetched utab); + | Some (uall,true) -> mk_library lsd lmd (Dvivo (digest_lmd,digest_u)) uall - | Some (utab,_,false) -> - add_univ_table lsd.md_name (Fetched utab); + | Some (_,false) -> mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty module DPMap = Map.Make(DirPath) -let rec intern_library (needed, contents) (dir, f) from = +let rec intern_library ~lib_resolver (needed, contents) (dir, f) from = (* Look if in the current logical environment *) try (find_library dir).libsum_digests, (needed, contents) with Not_found -> @@ -459,7 +370,7 @@ let rec intern_library (needed, contents) (dir, f) from = with Not_found -> Feedback.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* [dir] is an absolute name which matches [f] which must be in loadpath *) - let f = match f with Some f -> f | None -> try_locate_absolute_library dir in + let f = match f with Some f -> f | None -> lib_resolver dir in let m = intern_from_file f in if not (DirPath.equal dir m.library_name) then user_err ~hdr:"load_physical_library" @@ -467,22 +378,24 @@ let rec intern_library (needed, contents) (dir, f) from = DirPath.print m.library_name ++ spc () ++ str "and not library" ++ spc() ++ DirPath.print dir); Feedback.feedback (Feedback.FileLoaded(DirPath.to_string dir, f)); - m.library_digests, intern_library_deps (needed, contents) dir m f + m.library_digests, intern_library_deps ~lib_resolver (needed, contents) dir m f -and intern_library_deps libs dir m from = - let needed, contents = Array.fold_left (intern_mandatory_library dir from) libs m.library_deps in +and intern_library_deps ~lib_resolver libs dir m from = + let needed, contents = + Array.fold_left (intern_mandatory_library ~lib_resolver dir from) + libs m.library_deps in (dir :: needed, DPMap.add dir m contents ) -and intern_mandatory_library caller from libs (dir,d) = - let digest, libs = intern_library libs (dir, None) (Some from) in +and intern_mandatory_library ~lib_resolver caller from libs (dir,d) = + let digest, libs = intern_library ~lib_resolver libs (dir, None) (Some from) in if not (Safe_typing.digest_match ~actual:digest ~required:d) then user_err (str "Compiled library " ++ DirPath.print caller ++ str " (in file " ++ str from ++ str ") makes inconsistent assumptions \ over library " ++ DirPath.print dir); libs -let rec_intern_library libs (dir, f) = - let _, libs = intern_library libs (dir, Some f) None in +let rec_intern_library ~lib_resolver libs (dir, f) = + let _, libs = intern_library ~lib_resolver libs (dir, Some f) None in libs let native_name_from_filename f = @@ -557,8 +470,8 @@ let warn_require_in_module = strbrk "You can Require a module at toplevel " ++ strbrk "and optionally Import it inside another one.") -let require_library_from_dirpath modrefl export = - let needed, contents = List.fold_left rec_intern_library ([], DPMap.empty) modrefl in +let require_library_from_dirpath ~lib_resolver modrefl export = + let needed, contents = List.fold_left (rec_intern_library ~lib_resolver) ([], DPMap.empty) modrefl in let needed = List.rev_map (fun dir -> DPMap.find dir contents) needed in let modrefl = List.map fst modrefl in if Lib.is_module_or_modtype () then @@ -616,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 pi3 (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 + if snd (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); + s0, s1, Option.get s2, Option.get tasks, s4 (************************************************************************) (*s [save_library dir] ends library [dir] and save it to the disk. *) @@ -667,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, univ_table, disch_table, f2t_map = Opaqueproof.dump 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) -> @@ -678,18 +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_table,Univ.ContextSet.empty,false), - Some disch_table in - let except = - Future.UUIDSet.fold (fun uuid acc -> - try Int.Set.add (Future.UUIDMap.find uuid f2t_map) acc - with Not_found -> acc) - except Int.Set.empty in - let is_done_or_todo i x = Future.is_val x || Int.Set.mem i except in - Array.iteri (fun i x -> - if not(is_done_or_todo i x) then CErrors.user_err ~hdr:"library" - Pp.(str"Proof object "++int i++str" is not checked nor to be checked")) - opaque_table; + Some (Univ.ContextSet.empty,false) + in let sd = { md_name = dir; md_deps = Array.of_list (current_deps ()); @@ -709,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; @@ -729,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 390299bf56..727eca10cf 100644 --- a/library/library.mli +++ b/library/library.mli @@ -22,17 +22,20 @@ open Libnames (** {6 ... } Require = load in the environment + open (if the optional boolean is not [None]); mark also for export if the boolean is [Some true] *) -val require_library_from_dirpath : (DirPath.t * string) list -> bool option -> unit +val require_library_from_dirpath + : lib_resolver:(DirPath.t -> CUnix.physical_path) + -> (DirPath.t * string) list + -> bool option + -> unit (** {6 Start the compilation of a library } *) (** Segments of a library *) type seg_sum type seg_lib -type seg_univ = (* cst, all_cst, finished? *) - Univ.ContextSet.t Future.computation array * Univ.ContextSet.t * bool -type seg_discharge = Opaqueproof.cooking_info list array -type seg_proofs = Constr.constr Future.computation array +type seg_univ = (* all_cst, finished? *) + Univ.ContextSet.t * bool +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 *) @@ -45,8 +48,10 @@ val save_library_to : output_native_objects:bool -> DirPath.t -> string -> Opaqueproof.opaquetab -> unit -val load_library_todo : - string -> seg_sum * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs +val load_library_todo + : CUnix.physical_path + -> seg_sum * seg_lib * seg_univ * 'tasks * seg_proofs + val save_library_raw : string -> seg_sum -> seg_lib -> seg_univ -> seg_proofs -> unit (** {6 Interrogate the status of libraries } *) @@ -65,20 +70,8 @@ val library_full_filename : DirPath.t -> string (** - Overwrite the filename of all libraries (used when restoring a state) *) val overwrite_library_filenames : string -> unit -(** {6 Locate a library in the load paths } *) -exception LibUnmappedDir -exception LibNotFound -type library_location = LibLoaded | LibInPath - -val locate_qualified_library : - ?root:DirPath.t -> ?warn:bool -> qualid -> - library_location * DirPath.t * CUnix.physical_path -(** Locates a library by implicit name. - - @raise LibUnmappedDir if the library is not in the path - @raise LibNotFound if there is no corresponding file in the path - -*) - (** {6 Native compiler. } *) val native_name_from_filename : string -> string + +(** {6 Opaque accessors} *) +val indirect_accessor : Opaqueproof.indirect_accessor diff --git a/library/library.mllib b/library/library.mllib index 8f694f4a31..ef53471377 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -7,7 +7,6 @@ Global Decl_kinds Lib Declaremods -Loadpath Library States Kindops diff --git a/library/loadpath.ml b/library/loadpath.ml deleted file mode 100644 index fc13c864d0..0000000000 --- a/library/loadpath.ml +++ /dev/null @@ -1,119 +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 Pp -open Util -open CErrors -open Names -open Libnames - -(** Load paths. Mapping from physical to logical paths. *) - -type t = { - path_physical : CUnix.physical_path; - path_logical : DirPath.t; - path_implicit : bool; -} - -let load_paths = Summary.ref ([] : t list) ~name:"LOADPATHS" - -let logical p = p.path_logical - -let physical p = p.path_physical - -let get_load_paths () = !load_paths - -let anomaly_too_many_paths path = - anomaly (str "Several logical paths are associated to" ++ spc () ++ str path ++ str ".") - -let find_load_path phys_dir = - let phys_dir = CUnix.canonical_path_name phys_dir in - let filter p = String.equal p.path_physical phys_dir in - let paths = List.filter filter !load_paths in - match paths with - | [] -> raise Not_found - | [p] -> p - | _ -> anomaly_too_many_paths phys_dir - -let is_in_load_paths phys_dir = - let dir = CUnix.canonical_path_name phys_dir in - let lp = get_load_paths () in - let check_p p = String.equal dir p.path_physical in - List.exists check_p lp - -let remove_load_path dir = - let filter p = not (String.equal p.path_physical dir) in - load_paths := List.filter filter !load_paths - -let warn_overriding_logical_loadpath = - CWarnings.create ~name:"overriding-logical-loadpath" ~category:"loadpath" - (fun (phys_path, old_path, coq_path) -> - str phys_path ++ strbrk " was previously bound to " ++ - DirPath.print old_path ++ strbrk "; it is remapped to " ++ - DirPath.print coq_path) - -let add_load_path phys_path coq_path ~implicit = - let phys_path = CUnix.canonical_path_name phys_path in - let filter p = String.equal p.path_physical phys_path in - let binding = { - path_logical = coq_path; - path_physical = phys_path; - path_implicit = implicit; - } in - match List.filter filter !load_paths with - | [] -> - load_paths := binding :: !load_paths - | [{ path_logical = old_path; path_implicit = old_implicit }] -> - let replace = - if DirPath.equal coq_path old_path then - implicit <> old_implicit - else - let () = - (* Do not warn when overriding the default "-I ." path *) - if not (DirPath.equal old_path Libnames.default_root_prefix) then - warn_overriding_logical_loadpath (phys_path, old_path, coq_path) - in - true in - if replace then - begin - remove_load_path phys_path; - load_paths := binding :: !load_paths; - end - | _ -> anomaly_too_many_paths phys_path - -let filter_path f = - let rec aux = function - | [] -> [] - | p :: l -> - if f p.path_logical then (p.path_physical, p.path_logical) :: aux l - else aux l - in - aux !load_paths - -let expand_path ?root dir = - let rec aux = function - | [] -> [] - | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l -> - let success = - match root with - | None -> - if implicit then is_dirpath_suffix_of dir lg - else DirPath.equal dir lg - | Some root -> - is_dirpath_prefix_of root lg && - is_dirpath_suffix_of dir (drop_dirpath_prefix root lg) in - if success then (ph, lg) :: aux l else aux l in - aux !load_paths - -let locate_file fname = - let paths = List.map physical !load_paths in - let _,longfname = - System.find_file_in_path ~warn:(not !Flags.quiet) paths fname in - longfname diff --git a/library/nametab.mli b/library/nametab.mli index a4f177aad0..33cb4faf99 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -38,7 +38,7 @@ open Globnames } {- [exists : full_user_name -> bool] - Is the [full_user_name] already atributed as an absolute user name + Is the [full_user_name] already attributed as an absolute user name of some object? } {- [locate : qualid -> object_reference] diff --git a/library/summary.mli b/library/summary.mli index 0d77d725ac..3875bcfe9e 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -28,7 +28,7 @@ type 'a summary_declaration = { Beware: for tables registered dynamically after the initialization of Coq, their init functions may not be run immediately. It is hence - the responsability of plugins to initialize themselves properly. + the responsibility of plugins to initialize themselves properly. *) val declare_summary : string -> 'a summary_declaration -> unit diff --git a/man/coqdep.1 b/man/coqdep.1 index c417402c25..4639a75677 100644 --- a/man/coqdep.1 +++ b/man/coqdep.1 @@ -106,7 +106,7 @@ Skips subdirectory Output the given file name ordered by dependencies. .TP .B \-boot -For coq developpers, prints dependencies over coq library files +For coq developers, prints dependencies over coq library files (omitted by default). diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 4a9190c10a..79cfe33b12 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -31,8 +31,10 @@ let ldots_var = Id.of_string ".." let constr_kw = [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; "end"; "as"; "let"; "if"; "then"; "else"; "return"; - "SProp"; "Prop"; "Set"; "Type"; ".("; "_"; ".."; - "`{"; "`("; "{|"; "|}" ] + "SProp"; "Prop"; "Set"; "Type"; + ":="; "=>"; "->"; ".."; "<:"; "<<:"; ":>"; + ".("; "()"; "`{"; "`("; "@{"; "{|"; + "_"; "@"; "+"; "!"; "?"; ";"; ","; ":" ] let _ = List.iter CLexer.add_keyword constr_kw @@ -131,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; @@ -151,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: @@ -165,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 } @@ -225,11 +235,13 @@ GRAMMAR EXTEND Gram [ c=atomic_constr -> { c } | c=match_constr -> { c } | "("; c = operconstr LEVEL "200"; ")" -> - { (match c.CAst.v with + { (* Preserve parentheses around numerals so that constrintern does not + collapse -(3) into the numeral -3. *) + (match c.CAst.v with | CPrim (Numeral (SPlus,n)) -> CAst.make ~loc @@ CNotation((InConstrEntrySomeLevel,"( _ )"),([c],[],[],[])) | _ -> c) } - | "{|"; c = record_declaration; "|}" -> { c } + | "{|"; c = record_declaration; bar_cbrace -> { c } | "{"; c = binder_constr ; "}" -> { CAst.make ~loc @@ CNotation((InConstrEntrySomeLevel,"{ _ }"),([c],[],[],[])) } | "`{"; c = operconstr LEVEL "200"; "}" -> @@ -277,16 +289,16 @@ GRAMMAR EXTEND Gram ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> { CAst.make ~loc @@ CLetTuple (lb,po,c1,c2) } - | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; + | "let"; "'"; p = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> { CAst.make ~loc @@ CCases (LetPatternStyle, None, [c1, None, None], [CAst.make ~loc ([[p]], c2)]) } - | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; + | "let"; "'"; p = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> { CAst.make ~loc @@ CCases (LetPatternStyle, Some rt, [c1, aliasvar p, None], [CAst.make ~loc ([[p]], c2)]) } - | "let"; "'"; p=pattern; "in"; t = pattern LEVEL "200"; + | "let"; "'"; p = pattern LEVEL "200"; "in"; t = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> { CAst.make ~loc @@ @@ -324,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: @@ -359,7 +371,7 @@ GRAMMAR EXTEND Gram case_item: [ [ c=operconstr LEVEL "100"; ona = OPT ["as"; id=name -> { id } ]; - ty = OPT ["in"; t=pattern -> { t } ] -> + ty = OPT ["in"; t = pattern LEVEL "200" -> { t } ] -> { (c,ona,ty) } ] ] ; case_type: @@ -377,14 +389,14 @@ GRAMMAR EXTEND Gram [ [ OPT"|"; br=LIST0 eqn SEP "|" -> { br } ] ] ; mult_pattern: - [ [ pl = LIST1 pattern LEVEL "99" SEP "," -> { pl } ] ] + [ [ pl = LIST1 pattern LEVEL "200" SEP "," -> { pl } ] ] ; eqn: [ [ pll = LIST1 mult_pattern SEP "|"; "=>"; rhs = lconstr -> { (CAst.make ~loc (pll,rhs)) } ] ] ; record_pattern: - [ [ id = global; ":="; pat = pattern -> { (id, pat) } ] ] + [ [ id = global; ":="; pat = pattern LEVEL "200" -> { (id, pat) } ] ] ; record_patterns: [ [ p = record_pattern; ";"; ps = record_patterns -> { p :: ps } @@ -396,7 +408,10 @@ GRAMMAR EXTEND Gram pattern: [ "200" RIGHTA [ ] | "100" RIGHTA - [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> { CAst.make ~loc @@ CPatOr (p::pl) } ] + [ p = pattern; ":"; ty = binder_constr -> + {CAst.make ~loc @@ CPatCast (p, ty) } + | p = pattern; ":"; ty = operconstr LEVEL "100" -> + {CAst.make ~loc @@ CPatCast (p, ty) } ] | "99" RIGHTA [ ] | "90" RIGHTA [ ] | "10" LEFTA @@ -409,21 +424,17 @@ GRAMMAR EXTEND Gram [ c = pattern; "%"; key=IDENT -> { CAst.make ~loc @@ CPatDelimiters (key,c) } ] | "0" [ r = Prim.reference -> { CAst.make ~loc @@ CPatAtom (Some r) } - | "{|"; pat = record_patterns; "|}" -> { CAst.make ~loc @@ CPatRecord pat } + | "{|"; pat = record_patterns; bar_cbrace -> { CAst.make ~loc @@ CPatRecord pat } | "_" -> { CAst.make ~loc @@ CPatAtom None } | "("; p = pattern LEVEL "200"; ")" -> - { (match p.CAst.v with + { (* Preserve parentheses around numerals so that constrintern does not + collapse -(3) into the numeral -3. *) + (match p.CAst.v with | CPatPrim (Numeral (SPlus,n)) -> CAst.make ~loc @@ CPatNotation((InConstrEntrySomeLevel,"( _ )"),([p],[]),[]) | _ -> p) } - | "("; p = pattern LEVEL "200"; ":"; ty = lconstr; ")" -> - { let p = - match p with - | { CAst.v = CPatPrim (Numeral (SPlus,n)) } -> - CAst.make ~loc @@ CPatNotation((InConstrEntrySomeLevel,"( _ )"),([p],[]),[]) - | _ -> p - in - CAst.make ~loc @@ CPatCast (p, ty) } + | "("; p = pattern LEVEL "200"; "|" ; pl = LIST1 pattern LEVEL "200" SEP "|"; ")" -> + { CAst.make ~loc @@ CPatOr (p::pl) } | n = NUMERAL-> { CAst.make ~loc @@ CPatPrim (Numeral (SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPatPrim (String s) } ] ] ; @@ -500,9 +511,9 @@ GRAMMAR EXTEND Gram | "{"; id=name; idl=LIST1 name; "}" -> { List.map (fun id -> CLocalAssum ([id],Default Implicit, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) (id::idl) } | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" -> - { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Implicit, Explicit, b), t)) tc } + { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Explicit, b), t)) tc } | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" -> - { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Implicit, Implicit, b), t)) tc } + { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Implicit, b), t)) tc } | "'"; p = pattern LEVEL "0" -> { let (p, ty) = match p.CAst.v with diff --git a/parsing/g_prim.mlg b/parsing/g_prim.mlg index 80dd997860..9653964262 100644 --- a/parsing/g_prim.mlg +++ b/parsing/g_prim.mlg @@ -15,7 +15,7 @@ open Libnames open Pcoq.Prim -let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"] +let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"; "%"; "|"] let _ = List.iter CLexer.add_keyword prim_kw @@ -31,13 +31,19 @@ let my_int_of_string loc s = with Failure _ -> CErrors.user_err ~loc (Pp.str "This number is too large.") +let check_nospace loc expected = + let (bp, ep) = Loc.unloc loc in + if ep = bp + String.length expected then () else + Gramlib.Ploc.raise loc (Stream.Error ("'" ^ expected ^ "' expected")) + } GRAMMAR EXTEND Gram GLOBAL: bigint natural integer identref name ident var preident fullyqualid qualid reference dirpath ne_lstring - ne_string string lstring pattern_ident pattern_identref by_notation smart_global; + ne_string string lstring pattern_ident pattern_identref by_notation + smart_global bar_cbrace; preident: [ [ s = IDENT -> { s } ] ] ; @@ -123,4 +129,7 @@ GRAMMAR EXTEND Gram bigint: (* Negative numbers are dealt with elsewhere *) [ [ i = NUMERAL -> { check_int loc i } ] ] ; + bar_cbrace: + [ [ "|"; "}" -> { check_nospace loc "|}" } ] ] + ; END diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 8f38e437b4..b375c526ad 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -411,6 +411,8 @@ module Prim = let ne_string = Entry.create "Prim.ne_string" let ne_lstring = Entry.create "Prim.ne_lstring" + let bar_cbrace = Entry.create "'|}'" + end module Constr = @@ -425,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" @@ -585,7 +588,7 @@ let unfreeze (grams, lex) = (** No need to provide an init function : the grammar state is statically available, and already empty initially, while - the lexer state should not be resetted, since it contains + the lexer state should not be reset, since it contains keywords declared in g_*.ml4 *) let parser_summary_tag = diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 3a57c14a3b..196835f184 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -38,9 +38,9 @@ end - dynamic rules declared at the evaluation of Coq files (using e.g. Notation, Infix, or Tactic Notation) - - static rules explicitly defined in files g_*.ml4 + - static rules explicitly defined in files g_*.mlg - static rules macro-generated by ARGUMENT EXTEND, TACTIC EXTEND and - VERNAC EXTEND (see e.g. file extratactics.ml4) + VERNAC EXTEND (see e.g. file extratactics.mlg) Note that parsing a Coq document is in essence stateful: the parser needs to recognize commands that start proofs and use a different @@ -170,6 +170,7 @@ module Prim : val ne_string : string Entry.t val ne_lstring : lstring Entry.t val var : lident Entry.t + val bar_cbrace : unit Entry.t end module Constr : @@ -181,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/CHANGES b/plugins/extraction/CHANGES index 4bc3dba36e..bc7e1448f7 100644 --- a/plugins/extraction/CHANGES +++ b/plugins/extraction/CHANGES @@ -200,7 +200,7 @@ For the moment there are: Wf.well_founded_induction Wf.well_founded_induction_type Those constants does not match the auto-inlining criterion based on strictness. -Of course, you can still overide this behaviour via some Extraction NoInline. +Of course, you can still override this behaviour via some Extraction NoInline. * There is now a web page showing the extraction of all standard theories: http://www.lri.fr/~letouzey/extraction diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v index 36bb1148b6..02da168fd0 100644 --- a/plugins/extraction/ExtrOcamlBasic.v +++ b/plugins/extraction/ExtrOcamlBasic.v @@ -26,9 +26,9 @@ Extract Inductive prod => "( * )" [ "" ]. Extract Inductive sumbool => bool [ true false ]. Extract Inductive sumor => option [ Some None ]. -(** Restore lazyness of andb, orb. +(** Restore laziness of andb, orb. NB: without these Extract Constant, andb/orb would be inlined - by extraction in order to have lazyness, producing inelegant + by extraction in order to have laziness, producing inelegant (if ... then ... else false) and (if ... then true else ...). *) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 59c57cc544..f46d09e335 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -573,7 +573,7 @@ let pp_ocaml_gen k mp rls olab = if is_mp_bound base then pp_ocaml_bound base rls else pp_ocaml_extern k base rls -(* For Haskell, things are simplier: we have removed (almost) all structures *) +(* For Haskell, things are simpler: we have removed (almost) all structures *) let pp_haskell_gen k mp rls = match rls with | [] -> assert false @@ -590,7 +590,7 @@ let pp_global k r = let s = List.hd ls in let mp,l = repr_of_r r in if ModPath.equal mp (top_visible_mp ()) then - (* simpliest situation: definition of r (or use in the same context) *) + (* simplest situation: definition of r (or use in the same context) *) (* we update the visible environment *) (add_visible (k,s) l; unquote s) else @@ -607,7 +607,7 @@ let pp_module mp = let ls = mp_renaming mp in match mp with | MPdot (mp0,l) when ModPath.equal mp0 (top_visible_mp ()) -> - (* simpliest situation: definition of mp (or use in the same context) *) + (* simplest situation: definition of mp (or use in the same context) *) (* we update the visible environment *) let s = List.hd ls in add_visible (Mod,s) l; s 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/extraction.ml b/plugins/extraction/extraction.ml index 9db7c8d8d3..051d1f8e0f 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -115,7 +115,7 @@ let get_body lconstr = EConstr.of_constr (Mod_subst.force_constr lconstr) let get_opaque env c = EConstr.of_constr - (Opaqueproof.force_proof (Environ.opaque_tables env) c) + (Opaqueproof.force_proof Library.indirect_accessor (Environ.opaque_tables env) c) let applistc c args = EConstr.mkApp (c, Array.of_list args) diff --git a/plugins/extraction/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index d7bb27f121..9ea3fbeaf4 100644 --- a/plugins/extraction/g_extraction.mlg +++ b/plugins/extraction/g_extraction.mlg @@ -93,7 +93,7 @@ VERNAC COMMAND EXTEND Extraction CLASSIFIED AS QUERY END VERNAC COMMAND EXTEND SeparateExtraction CLASSIFIED AS QUERY -(* Same, with content splitted in several files *) +(* Same, with content split in several files *) | [ "Separate" "Extraction" ne_global_list(l) ] -> { separate_extraction l } END @@ -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/extraction/table.ml b/plugins/extraction/table.ml index 4e229a94b6..c2c48f9565 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -101,7 +101,7 @@ let labels_of_ref r = (*S The main tables: constants, inductives, records, ... *) -(* Theses tables are not registered within coq save/undo mechanism +(* These tables are not registered within coq save/undo mechanism since we reset their contents at each run of Extraction *) (* We use [constant_body] (resp. [mutual_inductive_body]) as checksum @@ -842,7 +842,7 @@ let in_customs : GlobRef.t * string list * string -> obj = ~subst:(Some (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str))) let in_custom_matchs : GlobRef.t * string -> obj = - declare_object @@ superglobal_object_nodischarge "ML extractions custom matchs" + declare_object @@ superglobal_object_nodischarge "ML extractions custom matches" ~cache:(fun (_,(r,s)) -> add_custom_match r s) ~subst:(Some (fun (subs,(r,s)) -> (fst (subst_global subs r), s))) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 287a374ab1..e38ea992ab 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -658,7 +658,7 @@ let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = *) (fun g -> -(* observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *) +(* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) thin [hid] g ) ) @@ -951,7 +951,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) let f_def = Global.lookup_constant (fst (destConst evd f)) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in - let (f_body, _) = Option.get (Global.body_of_constant_body f_def) in + let (f_body, _) = Option.get (Global.body_of_constant_body Library.indirect_accessor f_def) in let f_body = EConstr.of_constr f_body in let params,f_body_with_params = decompose_lam_n evd nb_params f_body in let (_,num),(_,_,bodies) = destFix evd f_body_with_params in @@ -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 -> @@ -1082,7 +1083,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam } in let get_body const = - match Global.body_of_constant const with + match Global.body_of_constant Library.indirect_accessor const with | Some (body, _) -> let env = Global.env () in let sigma = Evd.from_env env in diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index e9a2c285d0..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 @@ -413,7 +412,7 @@ let get_funs_constant mp = in function const -> let find_constant_body const = - match Global.body_of_constant const with + match Global.body_of_constant Library.indirect_accessor const with | Some (body, _) -> let body = Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) @@ -429,11 +428,11 @@ let get_funs_constant mp = let l_const = get_funs_constant const f in (* We need to check that all the functions found are in the same block - to prevent Reset stange thing + to prevent Reset strange thing *) let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in - (* all the paremeter must be equal*) + (* all the parameters must be equal*) let _check_params = let first_params = List.hd l_params in List.iter @@ -514,13 +513,13 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ ) fas in - (* We create the first priciple by tactic *) + (* We create the first principle by tactic *) let first_type,other_princ_types = match l_schemes with 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 e15e167ff3..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) @@ -1369,7 +1369,7 @@ let do_build_inductive (rebuild_return_type returned_types.(i)) in (* We need to lift back our work topconstr but only with all information - We mimick a Set Printing All. + We mimic a Set Printing All. Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in @@ -1438,7 +1438,7 @@ let do_build_inductive (rebuild_return_type returned_types.(i)) in (* We need to lift back our work topconstr but only with all information - We mimick a Set Printing All. + We mimic a Set Printing All. Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 481a8be3ba..24b3690138 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -55,7 +55,7 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr Glob_term.cases_pattern * Id.Map.key list * Id.t Id.Map.t -(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt +(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result respects barendregt conventions and does not share bound variables with avoid *) val alpha_rt : Id.t list -> glob_constr -> glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index ce7d149ae1..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 -> @@ -851,7 +851,7 @@ let make_graph ~pstate (f_ref : GlobRef.t) = end | _ -> raise (UserError (None, str "Not a function reference") ) in - (match Global.body_of_constant_body c_body with + (match Global.body_of_constant_body Library.indirect_accessor c_body with | None -> error "Cannot build a graph over an axiom!" | Some (body, _) -> let env = Global.env () in @@ -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/indfun_common.ml b/plugins/funind/indfun_common.ml index 40f66ce5eb..48cf040919 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -115,7 +115,7 @@ let eq = lazy(EConstr.of_constr (coq_constant "eq")) let refl_equal = lazy(EConstr.of_constr (coq_constant "eq_refl")) (*****************************************************************) -(* Copy of the standart save mechanism but without the much too *) +(* Copy of the standard save mechanism but without the much too *) (* slow reduction function *) (*****************************************************************) open Entries @@ -357,7 +357,7 @@ let add_Function is_general f = let pr_table env sigma = pr_table env sigma !from_function (*********************************) -(* Debuging *) +(* Debugging *) let functional_induction_rewrite_dependent_proofs = ref true let function_debug = ref false open Goptions diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index edb698280f..03568fc6c7 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -591,7 +591,7 @@ let rec reflexivity_with_destruct_cases g = (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] - is the tactic used to prove completness lemma. + is the tactic used to prove completeness lemma. [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. @@ -748,7 +748,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let funs = Array.of_list funs and graphs = Array.of_list graphs in let map (c, u) = mkConstU (c, EInstance.make u) in let funs_constr = Array.map map funs in - (* XXX STATE Why do we need this... why is the toplevel protection not enought *) + (* XXX STATE Why do we need this... why is the toplevel protection not enough *) funind_purify (fun () -> let env = Global.env () in @@ -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 @@ -928,7 +928,7 @@ let revert_graph kn post_tac hid g = [hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct] is the correctness lemma for [fconst]. - The sketch is the follwing~: + The sketch is the following~: \begin{enumerate} \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ (fails if it is not possible) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 1fca132655..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 @@ -1584,9 +1580,10 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num spc () ++ str"is defined" ) ) in - (* XXX STATE Why do we need this... why is the toplevel protection not enought *) + (* 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 f5098d2a34..0ded60d9c7 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -146,6 +146,23 @@ let discrHyp id = let injection_main with_evars c = elimOnConstrWithHoles (injClause None None) with_evars c +let isInjPat pat = match pat.CAst.v with IntroAction (IntroInjection _) -> Some pat.CAst.loc | _ -> None + +let decode_inj_ipat ?loc = function + (* For the "as [= pat1 ... patn ]" syntax *) + | [{ CAst.v = IntroAction (IntroInjection ipat) }] -> ipat + (* For the "as pat1 ... patn" syntax *) + | ([] | [_]) as ipat -> ipat + | pat1::pat2::_ as ipat -> + (* To be sure that there is no confusion of syntax, we check that no [= ...] occurs + in the non-singleton list of patterns *) + match isInjPat pat1 with + | Some _ -> user_err ?loc:pat2.CAst.loc (str "Unexpected pattern.") + | None -> + match List.map_filter isInjPat ipat with + | loc :: _ -> user_err ?loc (str "Unexpected injection pattern.") + | [] -> ipat + } TACTIC EXTEND injection @@ -158,15 +175,15 @@ TACTIC EXTEND einjection END TACTIC EXTEND injection_as | [ "injection" "as" intropattern_list(ipat)] -> - { injClause None (Some ipat) false None } + { injClause None (Some (decode_inj_ipat ipat)) false None } | [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> - { mytclWithHoles (injClause None (Some ipat)) false c } + { mytclWithHoles (injClause None (Some (decode_inj_ipat ipat))) false c } END TACTIC EXTEND einjection_as | [ "einjection" "as" intropattern_list(ipat)] -> - { injClause None (Some ipat) true None } + { injClause None (Some (decode_inj_ipat ipat)) true None } | [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> - { mytclWithHoles (injClause None (Some ipat)) true c } + { mytclWithHoles (injClause None (Some (decode_inj_ipat ipat))) true c } END TACTIC EXTEND simple_injection | [ "simple" "injection" ] -> { simpleInjClause None false None } @@ -914,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. *) @@ -946,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, @@ -1101,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 12b12bc7b0..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 @@ -310,12 +308,6 @@ TACTIC EXTEND setoid_transitivity END VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY -| ![ proof ] [ "Print" "Rewrite" "HintDb" preident(s) ] -> - { (* This command should not use the proof env, keeping previous - behavior as requested in review. *) - fun ~pstate -> - let sigma, env = Option.cata Pfedit.get_current_context - (let e = Global.env () in Evd.from_env e, e) pstate in - Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s); - pstate } +| [ "Print" "Rewrite" "HintDb" preident(s) ] -> + { Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) } END diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 963b7189f9..7b286e69dc 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -23,14 +23,12 @@ open Tacticals.New open Tactics open Pretype_errors open Typeclasses -open Classes open Constrexpr open Globnames open Evd open Tactypes open Locus open Locusops -open Decl_kinds open Elimschemes open Environ open Termops @@ -44,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. *) @@ -207,7 +205,7 @@ end) = struct let mk_relation env evd a = app_poly env evd relation [| a |] - (** Build an infered signature from constraints on the arguments and expected output + (** Build an inferred signature from constraints on the arguments and expected output relation *) let build_signature evars env m (cstrs : (types * types option) option list) @@ -1791,20 +1789,21 @@ let rec strategy_of_ast = function let mkappc s l = CAst.make @@ CAppExpl ((None,qualid_of_ident (Id.of_string s),None),l) let declare_an_instance n s args = - (((CAst.make @@ Name n),None), Explicit, + (((CAst.make @@ Name n),None), CAst.make @@ CAppExpl ((None, qualid_of_string s,None), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] -let anew_instance ~pstate atts binders instance fields = - let program_mode = atts.program in - new_instance ~pstate ~program_mode atts.polymorphic - binders instance (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 = @@ -1817,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) @@ -1950,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 = @@ -1973,58 +1972,63 @@ 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 = - (((CAst.make @@ Name instance_id),None), Explicit, - CAst.make @@ CAppExpl ( - (None, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper",None), - [cHole; s; m])) + let instance_name = (CAst.make @@ Name instance_id),None in + let instance_t = + CAst.make @@ CAppExpl + ((None, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper",None), + [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 binders instance - None - ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in - pstate + 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 (* 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/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 0eb7726a18..8bd69dd4fd 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -24,7 +24,7 @@ type direction_flag = bool (* true = Left-to-right false = right-to-right *) type lazy_flag = | General (* returns all possible successes *) | Select (* returns all successes of the first matching branch *) - | Once (* returns the first success in a maching branch + | Once (* returns the first success in a matching branch (not necessarily the first) *) type global_flag = (* [gfail] or [fail] *) | TacGlobal diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index fd303f5d94..f839c3e886 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -24,7 +24,7 @@ type direction_flag = bool (* true = Left-to-right false = right-to-right *) type lazy_flag = | General (* returns all possible successes *) | Select (* returns all successes of the first matching branch *) - | Once (* returns the first success in a maching branch + | Once (* returns the first success in a matching branch (not necessarily the first) *) type global_flag = (* [gfail] or [fail] *) | TacGlobal diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 800be2565d..4a0b01bcdc 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -855,7 +855,7 @@ let interp_binding_name ist env sigma = function | NamedHyp id -> (* If a name is bound, it has to be a quantified hypothesis *) (* user has to use other names for variables if these ones clash with *) - (* a name intented to be used as a (non-variable) identifier *) + (* a name intended to be used as a (non-variable) identifier *) try try_interp_ltac_var (coerce_to_quantified_hypothesis sigma) ist (Some (env,sigma)) (make id) with Not_found -> NamedHyp id @@ -2075,7 +2075,7 @@ let _ = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in let ist = { lfun; poly; extra; } in let tac = interp_tactic ist tac in - (* EJGA: We sould also pass the proof name if desired, for now + (* EJGA: We should also pass the proof name if desired, for now poly seems like enough to get reasonable behavior in practice *) let name, poly = Id.of_string "ltac_gen", poly in diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index 2b5e496168..7783661787 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -128,7 +128,7 @@ module PatternMatching (E:StaticEnvironment) = struct (** To focus on the algorithmic portion of pattern-matching, the bookkeeping is relegated to a monad: the composition of the - bactracking monad of {!IStream.t} with a "writer" effect. *) + backtracking monad of {!IStream.t} with a "writer" effect. *) (* spiwack: as we don't benefit from the various stream optimisations of Haskell, it may be costly to give the monad in direct style such as here. We may want to use some continuation passing style. *) diff --git a/plugins/micromega/DeclConstant.v b/plugins/micromega/DeclConstant.v index 47fcac6481..4e8fe5a8ff 100644 --- a/plugins/micromega/DeclConstant.v +++ b/plugins/micromega/DeclConstant.v @@ -62,6 +62,7 @@ Instance DZO: DeclaredConstant Z0 := {}. Instance DZpos: DeclaredConstant Zpos := {}. Instance DZneg: DeclaredConstant Zneg := {}. Instance DZpow_pos : DeclaredConstant Z.pow_pos := {}. +Instance DZpow : DeclaredConstant Z.pow := {}. Require Import QArith. diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 36ed0210e3..b20f45af3e 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -925,7 +925,7 @@ Qed. revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. - discriminate. - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. - * injection H as <-. rewrite <- PSubstL1_ok; intuition. + * injection H as [= <-]. rewrite <- PSubstL1_ok; intuition. * now apply IH. Qed. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 6112eda200..830cbdf7f6 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -55,7 +55,7 @@ Extract Constant Rinv => "fun x -> 1 / x". extraction is only performed as a test in the test suite. *) (*Extraction "micromega.ml" Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - ZMicromega.cnfZ ZMicromega.bound_problem_fr QMicromega.cnfQ + ZMicromega.cnfZ ZMicromega.Zeval_const ZMicromega.bound_problem_fr QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v index e0e2232be5..7759bda7c7 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -129,7 +129,7 @@ Proof. intros n m H1 H2; rewrite H2 in H1; now apply H1. Qed. -(* Propeties of plus, minus and opp *) +(* Properties of plus, minus and opp *) Theorem Rplus_0_l : forall n : R, 0 + n == n. Proof. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 60931df517..c5e179fbb8 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -990,7 +990,7 @@ Proof. rewrite IHs. reflexivity. Qed. -(** equality migth be (too) strong *) +(** equality might be (too) strong *) Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f). Proof. destruct f. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index ab218a1778..953690c510 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -75,6 +75,21 @@ Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := Definition eval_expr := eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => x) (pow_N 1 Z.mul). +Fixpoint Zeval_const (e: PExpr Z) : option Z := + match e with + | PEc c => Some c + | PEX _ x => None + | PEadd e1 e2 => map_option2 (fun x y => Some (x + y)) + (Zeval_const e1) (Zeval_const e2) + | PEmul e1 e2 => map_option2 (fun x y => Some (x * y)) + (Zeval_const e1) (Zeval_const e2) + | PEpow e1 n => map_option (fun x => Some (Z.pow x (Z.of_N n))) + (Zeval_const e1) + | PEsub e1 e2 => map_option2 (fun x y => Some (x - y)) + (Zeval_const e1) (Zeval_const e2) + | PEopp e => map_option (fun x => Some (Z.opp x)) (Zeval_const e) + end. + Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n. Proof. destruct n. diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index de9dec0f74..48027442b2 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -346,7 +346,9 @@ struct let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") - let coq_GT = lazy (m_constant "GT") + (* let coq_GT = lazy (m_constant "GT")*) + + let coq_DeclaredConstant = lazy (m_constant "DeclaredConstant") let coq_TT = lazy (gen_constant_in_modules "ZMicromega" @@ -462,13 +464,24 @@ struct what to consider as a constant (see [parse_constant]) *) - let is_ground_term env sigma term = - let typ = Retyping.get_type_of env sigma term in - try - ignore (Typeclasses.resolve_one_typeclass env sigma (EConstr.mkApp(Lazy.force coq_GT,[| typ;term|]))) ; - true - with - | Not_found -> false + let is_declared_term env evd t = + match EConstr.kind evd t with + | Const _ | Construct _ -> (* Restrict typeclass resolution to trivial cases *) + begin + let typ = Retyping.get_type_of env evd t in + try + ignore (Typeclasses.resolve_one_typeclass env evd (EConstr.mkApp(Lazy.force coq_DeclaredConstant,[| typ;t|]))) ; true + with Not_found -> false + end + | _ -> false + + let rec is_ground_term env evd term = + match EConstr.kind evd term with + | App(c,args) -> + is_declared_term env evd c && + Array.for_all (is_ground_term env evd) args + | Const _ | Construct _ -> is_declared_term env evd term + | _ -> false let parse_z sigma term = @@ -674,26 +687,28 @@ struct let parse_zop gl (op,args) = let sigma = gl.sigma in - match EConstr.kind sigma op with - | Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) - | Ind((n,0),_) -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" + match args with + | [| a1 ; a2|] -> assoc_const sigma op zop_table, a1, a2 + | [| ty ; a1 ; a2|] -> + if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl ty (Lazy.force coq_Z) + then (Mc.OpEq, args.(1), args.(2)) + else raise ParseError + | _ -> raise ParseError let parse_rop gl (op,args) = let sigma = gl.sigma in - match EConstr.kind sigma op with - | Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) - | Ind((n,0),_) -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" + match args with + | [| a1 ; a2|] -> assoc_const sigma op rop_table, a1 , a2 + | [| ty ; a1 ; a2|] -> + if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl ty (Lazy.force coq_R) + then (Mc.OpEq, a1, a2) + else raise ParseError + | _ -> raise ParseError let parse_qop gl (op,args) = - (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) + if Array.length args = 2 + then (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) + else raise ParseError type 'a op = | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) @@ -804,7 +819,7 @@ struct (op expr1 expr2,env) in try (Mc.PEc (parse_constant gl term) , env) - with ParseError -> + with ParseError -> match EConstr.kind gl.sigma term with | App(t,args) -> ( @@ -820,7 +835,7 @@ struct let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) - with e when CErrors.noncritical e -> + with ParseError -> (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end @@ -858,19 +873,48 @@ struct coq_Ropp , Opp ; coq_Rpower , Power] - (** [parse_constant parse gl t] returns the reification of term [t]. + let parse_constant parse gl t = parse gl.sigma t + + (** [parse_more_constant parse gl t] returns the reification of term [t]. If [t] is a ground term, then it is first reduced to normal form before using a 'syntactic' parser *) - let parse_constant parse gl t = - if is_ground_term gl.env gl.sigma t - then - parse gl.sigma (Redexpr.cbv_vm gl.env gl.sigma t) - else raise ParseError + let parse_more_constant parse gl t = + try + parse gl t + with ParseError -> + begin + if debug then Feedback.msg_debug Pp.(str "try harder"); + if is_ground_term gl.env gl.sigma t + then parse gl (Redexpr.cbv_vm gl.env gl.sigma t) + else raise ParseError + end let zconstant = parse_constant parse_z let qconstant = parse_constant parse_q let nconstant = parse_constant parse_nat + (** [parse_more_zexpr parse_constant gl] improves the parsing of exponent + which can be arithmetic expressions (without variables). + [parse_constant_expr] returns a constant if the argument is an expression without variables. *) + + let rec parse_zexpr gl = + parse_expr gl + zconstant + (fun expr (x:EConstr.t) -> + let z = parse_zconstant gl x in + match z with + | Mc.Zneg _ -> Mc.PEc Mc.Z0 + | _ -> Mc.PEpow(expr, Mc.Z.to_N z) + ) + zop_spec + and parse_zconstant gl e = + let (e,_) = parse_zexpr gl (Env.empty gl) e in + match Mc.zeval_const e with + | None -> raise ParseError + | Some z -> z + + + (* NB: R is a different story. Because it is axiomatised, reducing would not be effective. Therefore, there is a specific parser for constant over R @@ -905,7 +949,7 @@ struct let b = rconstant args.(1) in f a b with - ParseError -> + ParseError -> match op with | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> let arg = rconstant args.(0) in @@ -913,12 +957,12 @@ struct then raise ParseError (* This is a division by zero -- no semantics *) else Mc.CInv(arg) | op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) -> - Mc.CPow(rconstant args.(0) , Mc.Inr (nconstant gl args.(1))) + Mc.CPow(rconstant args.(0) , Mc.Inr (parse_more_constant nconstant gl args.(1))) | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> Mc.CQ (qconstant gl args.(0)) | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> - Mc.CZ (zconstant gl args.(0)) - | _ -> raise ParseError + Mc.CZ (parse_more_constant zconstant gl args.(0)) + | _ -> raise ParseError end | _ -> raise ParseError in @@ -934,14 +978,6 @@ struct res - let parse_zexpr gl = parse_expr gl - zconstant - (fun expr x -> - let exp = (zconstant gl x) in - match exp with - | Mc.Zneg _ -> Mc.PEc Mc.Z0 - | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) - zop_spec let parse_qexpr gl = parse_expr gl qconstant @@ -952,7 +988,7 @@ struct begin match expr with | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) - | _ -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError + | _ -> raise ParseError end | _ -> let exp = Mc.Z.to_N exp in Mc.PEpow(expr,exp)) @@ -1031,14 +1067,16 @@ struct let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg | _ -> parse_atom env tg term) - | Prod(typ,a,b) when EConstr.Vars.noccurn sigma 1 b -> + | Prod(typ,a,b) when typ.binder_name = Anonymous || EConstr.Vars.noccurn sigma 1 b -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg - | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (Mc.TT,env,tg) - | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> Mc.(FF,env,tg) - | _ when is_prop term -> Mc.X(term),env,tg - | _ -> raise ParseError + | _ -> if EConstr.eq_constr sigma term (Lazy.force coq_True) + then (Mc.TT,env,tg) + else if EConstr.eq_constr sigma term (Lazy.force coq_False) + then Mc.(FF,env,tg) + else if is_prop term then Mc.X(term),env,tg + else raise ParseError in xparse_formula env tg ((*Reductionops.whd_zeta*) term) @@ -1170,8 +1208,8 @@ let dump_rexpr = lazy (** [make_goal_of_formula depxr vars props form] where - - vars is an environment for the arithmetic variables occuring in form - - props is an environment for the propositions occuring in form + - vars is an environment for the arithmetic variables occurring in form + - props is an environment for the propositions occurring in form @return a goal where all the variables and propositions of the formula are quantified *) @@ -1358,19 +1396,11 @@ let rec parse_hyps gl parse_arith env tg hyps = let (c,env,tg) = parse_formula gl parse_arith env tg t in ((i,c)::lhyps, env,tg) with e when CErrors.noncritical e -> (lhyps,env,tg) - (*(if debug then Printf.printf "parse_arith : %s\n" x);*) - - -(*exception ParseError*) - - let parse_goal gl parse_arith (env:Env.t) hyps term = - (* try*) let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in (lhyps,f,env) - (* with Failure x -> raise ParseError*) (** * The datastructures that aggregate theory-dependent proof values. @@ -1439,7 +1469,7 @@ let pre_processZ mt f = x <= y or (x and y are incomparable) *) (** - * Instanciate the current Coq goal with a Micromega formula, a varmap, and a + * Instantiate the current Coq goal with a Micromega formula, a varmap, and a * witness. *) @@ -1886,7 +1916,7 @@ let micromega_genr prover tac = ] with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") + | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") | CsdpNotFound -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index b34c3b2b7d..a64a5a84b3 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -230,6 +230,13 @@ module Coq_Pos = | XO p -> XO (mul p y) | XH -> y + (** val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) + + let rec iter f x = function + | XI n' -> f (iter f (iter f x n') n') + | XO n' -> iter f (iter f x n') n' + | XH -> f x + (** val size_nat : positive -> nat **) let rec size_nat = function @@ -398,6 +405,18 @@ module Z = | Zpos y' -> Zneg (Coq_Pos.mul x' y') | Zneg y' -> Zpos (Coq_Pos.mul x' y')) + (** val pow_pos : z -> positive -> z **) + + let pow_pos z0 = + Coq_Pos.iter (mul z0) (Zpos XH) + + (** val pow : z -> z -> z **) + + let pow x = function + | Z0 -> Zpos XH + | Zpos p -> pow_pos x p + | Zneg _ -> Z0 + (** val compare : z -> z -> comparison **) let compare x y = @@ -460,6 +479,12 @@ module Z = | O -> Z0 | S n1 -> Zpos (Coq_Pos.of_succ_nat n1) + (** val of_N : n -> z **) + + let of_N = function + | N0 -> Z0 + | Npos p -> Zpos p + (** val pos_div_eucl : positive -> z -> z * z **) let rec pos_div_eucl a b = @@ -1642,6 +1667,21 @@ let rec vm_add default x v = function | XO p -> Branch ((vm_add default p v l), o, r) | XH -> Branch (l, v, r)) +(** val zeval_const : z pExpr -> z option **) + +let rec zeval_const = function +| PEc c -> Some c +| PEX _ -> None +| PEadd (e1, e2) -> + map_option2 (fun x y -> Some (Z.add x y)) (zeval_const e1) (zeval_const e2) +| PEsub (e1, e2) -> + map_option2 (fun x y -> Some (Z.sub x y)) (zeval_const e1) (zeval_const e2) +| PEmul (e1, e2) -> + map_option2 (fun x y -> Some (Z.mul x y)) (zeval_const e1) (zeval_const e2) +| PEopp e0 -> map_option (fun x -> Some (Z.opp x)) (zeval_const e0) +| PEpow (e1, n0) -> + map_option (fun x -> Some (Z.pow x (Z.of_N n0))) (zeval_const e1) + type zWitness = z psatz (** val zWeakChecker : z nFormula list -> z psatz -> bool **) diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 5de6caac0b..64cb3a8355 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -86,6 +86,8 @@ module Coq_Pos : val mul : positive -> positive -> positive + val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1 + val size_nat : positive -> nat val compare_cont : comparison -> positive -> positive -> comparison @@ -124,6 +126,10 @@ module Z : val mul : z -> z -> z + val pow_pos : z -> positive -> z + + val pow : z -> z -> z + val compare : z -> z -> comparison val leb : z -> z -> bool @@ -140,6 +146,8 @@ module Z : val of_nat : nat -> z + val of_N : n -> z + val pos_div_eucl : positive -> z -> z * z val div_eucl : z -> z -> z * z @@ -179,20 +187,20 @@ val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 - pol -> 'a1 pol + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol + -> 'a1 pol val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> + 'a1 pol -> 'a1 pol val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> - 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 + pol -> positive -> 'a1 pol -> 'a1 pol val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol @@ -205,20 +213,19 @@ val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 - pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> - 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 + pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - 'a1 pol -> 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + pol -> 'a1 pol -> 'a1 pol val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + pol -> 'a1 pol type 'c pExpr = | PEc of 'c @@ -232,16 +239,16 @@ type 'c pExpr = val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 + pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 + pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type ('tA, 'tX, 'aA, 'aF) gFormula = | TT @@ -253,8 +260,7 @@ type ('tA, 'tX, 'aA, 'aF) gFormula = | N of ('tA, 'tX, 'aA, 'aF) gFormula | I of ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula -val mapX : - ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula +val mapX : ('a2 -> 'a2) -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula val foldA : ('a5 -> 'a3 -> 'a5) -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 @@ -278,37 +284,36 @@ val cnf_tt : ('a1, 'a2) cnf val cnf_ff : ('a1, 'a2) cnf val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> - ('a1, 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, + 'a2) clause option val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) - clause -> ('a1, 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) clause -> + ('a1, 'a2) clause option val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> + ('a1, 'a2) cnf val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> - ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> - ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> + 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val radd_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> (('a1, 'a2) clause, 'a2 list) sum val ror_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause - -> (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause -> + (('a1, 'a2) clause, 'a2 list) sum val ror_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause @@ -319,17 +324,16 @@ val ror_cnf : clause list -> ('a1, 'a2) cnf * 'a2 list val rxcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> - ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, - 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> + 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 + list -val cnf_checker : - (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool +val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> - ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, - 'a3, unit0) gFormula -> 'a4 list -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> + 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, 'a3, unit0) + gFormula -> 'a4 list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool @@ -363,27 +367,27 @@ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + polC -> 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 + nFormula -> 'a1 nFormula -> 'a1 nFormula option val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula - -> 'a1 nFormula option + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> + 'a1 nFormula option val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 + -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> - ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 + -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool type op2 = | OpEq @@ -396,8 +400,8 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> @@ -407,20 +411,20 @@ val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> - ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 + -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr @@ -475,6 +479,8 @@ val singleton : 'a1 -> positive -> 'a1 -> 'a1 t val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t +val zeval_const : z pExpr -> z option + type zWitness = z psatz val zWeakChecker : z nFormula list -> z psatz -> bool @@ -563,12 +569,12 @@ val bound_var : positive -> z formula val mk_eq_pos : positive -> positive -> positive -> z formula val bound_vars : - (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, - 'a1, 'a2, 'a3) gFormula + (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, 'a1, + 'a2, 'a3) gFormula val bound_problem_fr : - (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, - 'a3) gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula + (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, 'a3) + gFormula -> (z formula, 'a1, 'a2, 'a3) gFormula val zChecker : z nFormula list -> zArithProof -> bool diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 0209030b64..f038f8a71a 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -21,7 +21,7 @@ module type PHashtable = val open_in : string -> 'a t (** [open_in f] rebuilds a table from the records stored in file [f]. - As marshaling is not type-safe, it migth segault. + As marshaling is not type-safe, it might segfault. *) val find : 'a t -> key -> 'a diff --git a/plugins/micromega/persistent_cache.mli b/plugins/micromega/persistent_cache.mli index 4e7a388aaf..d2f3e756a9 100644 --- a/plugins/micromega/persistent_cache.mli +++ b/plugins/micromega/persistent_cache.mli @@ -17,7 +17,7 @@ module type PHashtable = val open_in : string -> 'a t (** [open_in f] rebuilds a table from the records stored in file [f]. - As marshaling is not type-safe, it migth segault. + As marshaling is not type-safe, it might segfault. *) val find : 'a t -> key -> 'a diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml index 6aebc4ca9a..e3a9f6f60f 100644 --- a/plugins/micromega/sos_lib.ml +++ b/plugins/micromega/sos_lib.ml @@ -200,7 +200,7 @@ let is_undefined f = | _ -> false;; (* ------------------------------------------------------------------------- *) -(* Operation analagous to "map" for lists. *) +(* Operation analogous to "map" for lists. *) (* ------------------------------------------------------------------------- *) let mapf = diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 1777418ef6..bece316c7d 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -267,7 +267,7 @@ module PIdeal = Ideal.Make(Poly) open PIdeal (* term to sparse polynomial - varaibles <=np are in the coefficients + variables <=np are in the coefficients *) let term_pol_sparse nvars np t= diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml index 5db587b9cc..f6ca232c2e 100644 --- a/plugins/nsatz/polynom.ml +++ b/plugins/nsatz/polynom.ml @@ -357,7 +357,7 @@ let remP v p = moinsP p (multP (coefDom v p) (puisP (x v) (deg v p))) -(* first interger coefficient of p *) +(* first integer coefficient of p *) let rec coef_int_tete p = let v = max_var_pol p in if v>0 @@ -526,7 +526,7 @@ let div_pol_rat p q= (* pseudo division : q = c*x^m+q1 - retruns (r,c,d,s) s.t. c^d*p = s*q + r. + returns (r,c,d,s) s.t. c^d*p = s*q + r. *) let pseudo_div p q x = diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 695f000cb1..23d7b141a4 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -359,7 +359,10 @@ Ltac zify_positive_rel := Ltac zify_positive_op := match goal with - (* Zneg -> -Zpos (except for numbers) *) + (* Z.pow_pos -> Z.pow *) + | H : context [ Z.pow_pos ?a ?b ] |- _ => change (Z.pow_pos a b) with (Z.pow a (Z.pos b)) in H + | |- context [ Z.pow_pos ?a ?b ] => change (Z.pow_pos a b) with (Z.pow a (Z.pos b)) + (* Zneg -> -Zpos (except for numbers) *) | H : context [ Zneg ?a ] |- _ => let isp := isPcst a in match isp with @@ -377,6 +380,10 @@ Ltac zify_positive_op := | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) + (* Z.power_pos *) + | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H + | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) + (* Pos.add -> Z.add *) | H : context [ Zpos (?a + ?b) ] |- _ => change (Zpos (a+b)) with (Zpos a + Zpos b) in H | |- context [ Zpos (?a + ?b) ] => change (Zpos (a+b)) with (Zpos a + Zpos b) diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index 4886c8b9aa..9be2535a3f 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -105,7 +105,7 @@ Section ZMORPHISM. Proof. constructor. destruct c;intros;try discriminate. - injection H as <-. + injection H as [= <-]. simpl. unfold Zeq_bool. rewrite Z.compare_refl. trivial. Qed. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index f7cb6b688b..c5d396427b 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -894,7 +894,7 @@ Section MakeRingPol. revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. - discriminate. - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. - * injection H as <-. rewrite <- PSubstL1_ok; intuition. + * injection H as [= <-]. rewrite <- PSubstL1_ok; intuition. * now apply IH. Qed. diff --git a/plugins/setoid_ring/g_newring.mlg b/plugins/setoid_ring/g_newring.mlg index 6be556b2ae..5dfead2d7e 100644 --- a/plugins/setoid_ring/g_newring.mlg +++ b/plugins/setoid_ring/g_newring.mlg @@ -13,8 +13,6 @@ open Ltac_plugin open Pp open Util -open Libnames -open Printer open Newring_ast open Newring open Stdarg @@ -85,21 +83,10 @@ END VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> - { let l = match l with None -> [] | Some l -> l in add_theory id t l } - | ![proof] [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { - fun ~pstate -> - Feedback.msg_notice (strbrk "The following ring structures have been declared:"); - Spmap.iter (fun fn fi -> - (* We should use the global env here as this shouldn't contain proof - data, however preserving behavior as requested in review. *) - let sigma, env = Option.cata Pfedit.get_current_context - (let e = Global.env () in Evd.from_env e, e) pstate in - Feedback.msg_notice (hov 2 - (Ppconstr.pr_id (Libnames.basename fn)++spc()++ - str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++ - str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req)) - ) !from_name; - pstate } + { add_theory id t (Option.default [] l) } + | [ "Print" "Rings" ] => { Vernacextend.classify_as_query } -> { + print_rings () + } END TACTIC EXTEND ring_lookup @@ -135,20 +122,9 @@ END VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> { let l = match l with None -> [] | Some l -> l in add_field_theory id t l } -| ![proof] [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { - fun ~pstate -> - Feedback.msg_notice (strbrk "The following field structures have been declared:"); - Spmap.iter (fun fn fi -> - (* We should use the global env here as this shouldn't - contain proof data. *) - let sigma, env = Option.cata Pfedit.get_current_context - (let e = Global.env () in Evd.from_env e, e) pstate in - Feedback.msg_notice (hov 2 - (Ppconstr.pr_id (Libnames.basename fn)++spc()++ - str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++ - str"and equivalence relation "++ pr_constr_env env sigma fi.field_req)) - ) !field_from_name; - pstate } +| [ "Print" "Fields" ] => {Vernacextend.classify_as_query} -> { + print_fields () + } END TACTIC EXTEND field_lookup diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index b02b97f656..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 *) @@ -327,6 +329,18 @@ module Cmap = Map.Make(Constr) let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table" let from_name = Summary.ref Spmap.empty ~name:"ring-tac-name-table" +let print_rings () = + Feedback.msg_notice (strbrk "The following ring structures have been declared:"); + Spmap.iter (fun fn fi -> + let env = Global.env () in + let sigma = Evd.from_env env in + Feedback.msg_notice + (hov 2 + (Ppconstr.pr_id (Libnames.basename fn)++spc()++ + str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++ + str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req)) + ) !from_name + let ring_for_carrier r = Cmap.find r !from_carrier let find_ring_structure env sigma l = @@ -824,6 +838,18 @@ let dest_field env evd th_spec = let field_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table" let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table" +let print_fields () = + Feedback.msg_notice (strbrk "The following field structures have been declared:"); + Spmap.iter (fun fn fi -> + let env = Global.env () in + let sigma = Evd.from_env env in + Feedback.msg_notice + (hov 2 + (Ppconstr.pr_id (Libnames.basename fn)++spc()++ + str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++ + str"and equivalence relation "++ pr_constr_env env sigma fi.field_req)) + ) !field_from_name + let field_for_carrier r = Cmap.find r !field_from_carrier let find_field_structure env sigma l = diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli index fcd04a2e73..3a21a82c5c 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/setoid_ring/newring.mli @@ -10,7 +10,6 @@ open Names open EConstr -open Libnames open Constrexpr open Newring_ast @@ -23,7 +22,7 @@ val add_theory : constr_expr -> constr_expr ring_mod list -> unit -val from_name : ring_info Spmap.t ref +val print_rings : unit -> unit val ring_lookup : Geninterp.Val.t -> @@ -35,7 +34,7 @@ val add_field_theory : constr_expr -> constr_expr field_mod list -> unit -val field_from_name : field_info Spmap.t ref +val print_fields : unit -> unit val field_lookup : Geninterp.Val.t -> diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index 49d729bd6c..c5f387b248 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -49,7 +49,7 @@ Require Import ssreflect ssrfun. altP (idP my_formula) but circumventing the dependent index capture issue; destructing boolP my_formula generates two subgoals with - assumtions my_formula and ~~ myformula. As + assumptions my_formula and ~~ myformula. As with altP, my_formula must be an application. \unless C, P <-> we can assume property P when a something that holds under condition C (such as C itself). @@ -64,7 +64,7 @@ Require Import ssreflect ssrfun. := forall b : bool, (P -> b) -> b. This is equivalent to ~ (~ P) when P : Prop. implies P Q == wrapper variant type that coerces to P -> Q and - can be used as a P -> Q view unambigously. + can be used as a P -> Q view unambiguously. Useful to avoid spurious insertion of <-> views when Q is a conjunction of foralls, as in Lemma all_and2 below; conversely, avoids confusion in @@ -1003,7 +1003,7 @@ Proof. by case: a; case: b. Qed. Lemma negb_or (a b : bool) : ~~ (a || b) = ~~ a && ~~ b. Proof. by case: a; case: b. Qed. -(** Pseudo-cancellation -- i.e, absorbtion **) +(** Pseudo-cancellation -- i.e, absorption **) Lemma andbK a b : a && b || a = a. Proof. by case: a; case: b. Qed. Lemma andKb a b : a || b && a = a. Proof. by case: a; case: b. Qed. @@ -1245,7 +1245,7 @@ Notation "[ 'pred' x : T | E1 & E2 ]" := (** Coercions for simpl_pred. As simpl_pred T values are used both applicatively and collectively we need simpl_pred to coerce to both pred T _and_ {pred T}. However it is - undesireable to have two distinct constants for what are essentially identical + undesirable to have two distinct constants for what are essentially identical coercion functions, as this confuses the SSReflect keyed matching algorithm. While the Coq Coercion declarations appear to disallow such Coercion aliasing, it is possible to work around this limitation with a combination of modules @@ -1331,9 +1331,9 @@ Variant mem_pred T := Mem of pred T. Similarly to pred_of_simpl, it will usually not be inserted by type inference, as all mem_pred mp =~= pred_sort ?pT unification problems will be solve by the memPredType instance below; pred_of_mem will however - be used if a mem_pred T is used as a {pred T}, which is desireable as it + be used if a mem_pred T is used as a {pred T}, which is desirable as it will avoid a redundant mem in a collective, e.g., passing (mem A) to a lemma - expection a generic collective predicate p : {pred T} and premise x \in P + exception a generic collective predicate p : {pred T} and premise x \in P will display a subgoal x \in A rathere than x \in mem A. Conversely, pred_of_mem will _not_ if it is used id (mem A) is used applicatively or as a pred T; there the simpl_of_mem coercion defined below @@ -1396,7 +1396,7 @@ Notation "[ 'rel' x y 'in' A & B ]" := Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] : fun_scope. Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] : fun_scope. -(** Aliases of pred T that let us tag intances of simpl_pred as applicative +(** Aliases of pred T that let us tag instances of simpl_pred as applicative or collective, via bespoke coercions. This tagging will give control over the simplification behaviour of inE and othe rewriting lemmas below. For this control to work it is crucial that collective_of_simpl _not_ @@ -1428,7 +1428,7 @@ Implicit Types (mp : mem_pred T). - registered_applicative_pred: this user-facing structure is used to declare values of type pred T meant to be used applicatively. The structure parameter merely displays this same value, and is used to avoid - undesireable, visible occurrence of the structure in the right hand side + undesirable, visible occurrence of the structure in the right hand side of rewrite rules such as app_predE. There is a canonical instance of registered_applicative_pred for values of the applicative_of_simpl coercion, which handles the @@ -1454,7 +1454,7 @@ Implicit Types (mp : mem_pred T). has been fixed earlier by the manifest_mem_pred match. In particular the definition of a predicate using the applicative_pred_of_simpl idiom above will not be expanded - this very case is the reason in_applicative uses - a mem_pred telescope in its left hand side. The more straighforward + a mem_pred telescope in its left hand side. The more straightforward ?x \in applicative_pred_value ?ap (equivalent to in_mem ?x (Mem ?ap)) with ?ap : registered_applicative_pred ?p would set ?p := [pred x | ...] rather than ?p := Apred in the example above. 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/ssreflect.v b/plugins/ssr/ssreflect.v index 5e3e8ce5fb..572d72ccd8 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -132,7 +132,7 @@ Delimit Scope ssripat_scope with ssripat. Make the general "if" into a notation, so that we can override it below. The notations are "only parsing" because the Coq decompiler will not recognize the expansion of the boolean if; using the default printer - avoids a spurrious trailing %%GEN_IF. **) + avoids a spurious trailing %%GEN_IF. **) Declare Scope general_if_scope. Delimit Scope general_if_scope with GEN_IF. @@ -347,10 +347,10 @@ Register protect_term as plugins.ssreflect.protect_term. (** The ssreflect idiom for a non-keyed pattern: - - unkeyed t wiil match any subterm that unifies with t, regardless of + - unkeyed t will match any subterm that unifies with t, regardless of whether it displays the same head symbol as t. - unkeyed t a b will match any application of a term f unifying with t, - to two arguments unifying with with a and b, repectively, regardless of + to two arguments unifying with with a and b, respectively, regardless of apparent head symbols. - unkeyed x where x is a variable will match any subterm with the same type as x (when x would raise the 'indeterminate pattern' error). **) @@ -380,7 +380,7 @@ Notation "=^~ r" := (ssr_converse r) : form_scope. locked_with k t is equal but not convertible to t, much like locked t, but supports explicit tagging with a value k : unit. This is used to mitigate a flaw in the term comparison heuristic of the Coq kernel, - which treats all terms of the form locked t as equal and conpares their + which treats all terms of the form locked t as equal and compares their arguments recursively, leading to an exponential blowup of comparison. For this reason locked_with should be used rather than locked when defining ADT operations. The unlock tactic does not support locked_with @@ -523,7 +523,7 @@ Hint View for apply/ iffRLn|2 iffLRn|2 iffRL|2 iffLR|2. elim/abstract_context: (pattern) => G defG. vm_compute; rewrite {}defG {G}. Note that vm_cast are not stored in the proof term - for reductions occuring in the context, hence + for reductions occurring in the context, hence set here := pattern; vm_compute in (value of here) blows up at Qed time. **) Lemma abstract_context T (P : T -> Type) x : @@ -637,7 +637,7 @@ Ltac over := later complain that it cannot erase _top_assumption_ after having abstracted the viewed assumption. Making x and y maximal implicits would avoid this and force the intended @Some_inj nat x y _top_assumption_ - interpretation, but is undesireable as it makes it harder to use Some_inj + interpretation, but is undesirable as it makes it harder to use Some_inj with the many SSReflect and MathComp lemmas that have an injectivity premise. Specifying {T : nonPropType} solves this more elegantly, as then (?T : Type) no longer unifies with (Some n = Some 0), which has sort Prop. @@ -655,13 +655,13 @@ Module NonPropType. maybeProp T to tt and use the test_negative instance and set ?r to false. - call_of c r sets up a call to test_of on condition c with expected result r. It has a default instance for its 'callee' projection to Type, which - sets c := maybeProj T and r := false whe unifying with a type T. + sets c := maybeProj T and r := false when unifying with a type T. - type is a telescope on call_of c r, which checks that unifying test_of ?r1 with c indeed sets ?r1 := r; the type structure bundles the 'test' instance and its 'result' value along with its call_of c r projection. The default instance essentially provides eta-expansion for 'type'. This is only essential for the first 'result' projection to bool; using the instance - for other projection merely avoids spurrious delta expansions that would + for other projection merely avoids spurious delta expansions that would spoil the notProp T notation. In detail, unifying T =~= ?S with ?S : nonPropType, i.e., (1) T =~= @callee (@condition (result ?S) (test ?S)) (result ?S) (frame ?S) diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 675e4d2457..3a0868b7e4 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -96,7 +96,7 @@ let subgoals_tys sigma (relctx, concl) = * (occ, c), deps and the pattern inferred from the type of the eliminator * 3. build the new predicate matching the patterns, and the tactic to * generalize the equality in case eqid is not None - * 4. build the tactic handle intructions and clears as required in ipats and + * 4. build the tactic handle instructions and clears as required in ipats and * by eqid *) let get_eq_type gl = @@ -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 93c0d5c236..dbb0f25abf 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -128,7 +128,7 @@ let newssrcongrtac arg ist gl = x, re_sig si sigma in let arr, gl = pf_mkSsrConst "ssr_congr_arrow" gl in let ssr_congr lr = EConstr.mkApp (arr, lr) in - (* here thw two cases: simple equality or arrow *) + (* here the two cases: simple equality or arrow *) let equality, _, eq_args, gl' = let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in pf_saturate gl (EConstr.of_constr eq) 3 in @@ -313,7 +313,7 @@ let rw_progress rhs lhs ise = not (EConstr.eq_constr ise lhs (Evarutil.nf_evar i (* Coq has a more general form of "equation" (any type with a single *) (* constructor with no arguments with_rect_r elimination lemmas). *) (* However there is no clear way of determining the LHS and RHS of *) -(* such a generic Leibnitz equation -- short of inspecting the type *) +(* such a generic Leibniz equation -- short of inspecting the type *) (* of the elimination lemmas. *) let rec strip_prod_assum c = match Constr.kind c with @@ -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/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 08f028465b..8880a6516e 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -566,12 +566,10 @@ let print_view_hints env sigma kind l = } VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY -| ![proof] [ "Print" "Hint" "View" ssrviewpos(i) ] -> +| [ "Print" "Hint" "View" ssrviewpos(i) ] -> { - fun ~pstate -> - (* XXX this is incorrect *) - let sigma, env = Option.cata Pfedit.get_current_context - (let e = Global.env () in Evd.from_env e, e) pstate in + let env = Global.env () in + let sigma = Evd.from_env env in (match i with | Some k -> print_view_hints env sigma k (Ssrview.AdaptorDb.get k) @@ -579,8 +577,7 @@ VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY List.iter (fun k -> print_view_hints env sigma k (Ssrview.AdaptorDb.get k)) [ Ssrview.AdaptorDb.Forward; Ssrview.AdaptorDb.Backward; - Ssrview.AdaptorDb.Equivalence ]); - pstate + Ssrview.AdaptorDb.Equivalence ]) } END diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 25975c84e8..6d1d858648 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -143,7 +143,7 @@ val mk_tpattern : type find_P = env -> constr -> int -> k:subst -> constr -(** [conclude ()] asserts that all mentioned ocurrences have been visited. +(** [conclude ()] asserts that all mentioned occurrences have been visited. @return the instance of the pattern, the evarmap after the pattern instantiation, the proof term and the ssrdit stored in the tpattern @raise UserEerror if too many occurrences were specified *) diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index 0f0f3953da..5808385723 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -34,23 +34,8 @@ VERNAC ARGUMENT EXTEND numnotoption END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] ![proof][ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) numnotoption(o) ] -> - { (* It is a bug to use the proof context here, but at the request of - * the reviewers we keep this broken behavior for now. The Global env - * should be used instead, and the `env, sigma` parameteter to the - * numeral notation command removed. - *) - fun ~pstate -> - let sigma, env = match pstate with - | None -> - let env = Global.env () in - let sigma = Evd.from_env env in - sigma, env - | Some pstate -> - Pfedit.get_current_context pstate - in - vernac_numeral_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) o; - pstate } + { vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } END diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg index cc8c13a84b..1e06cd8ddb 100644 --- a/plugins/syntax/g_string.mlg +++ b/plugins/syntax/g_string.mlg @@ -19,22 +19,7 @@ open Stdarg } VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] ![proof] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) ] -> - { (* It is a bug to use the proof context here, but at the request of - * the reviewers we keep this broken behavior for now. The Global env - * should be used instead, and the `env, sigma` parameteter to the - * numeral notation command removed. - *) - fun ~pstate -> - let sigma, env = match pstate with - | None -> - let env = Global.env () in - let sigma = Evd.from_env env in - sigma, env - | Some pstate -> - Pfedit.get_current_context pstate - in - vernac_string_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc); - pstate } + { vernac_string_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) } END diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index ec8c2338fb..b0b6fa69bb 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -101,7 +101,9 @@ let type_error_of g ty = str " to Decimal.int or (option Decimal.int)." ++ fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int or Decimal.decimal could be used (you may need to require BinNums or Decimal or Int63 first).") -let vernac_numeral_notation env sigma local ty f g scope opts = +let vernac_numeral_notation local ty f g scope opts = + let env = Global.env () in + let sigma = Evd.from_env env in let dec_ty = locate_decimal () in let z_pos_ty = locate_z () in let int63_ty = locate_int63 () in diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli index b14ed18497..3fc0385f5d 100644 --- a/plugins/syntax/numeral.mli +++ b/plugins/syntax/numeral.mli @@ -14,6 +14,6 @@ open Notation (** * Numeral notation *) -val vernac_numeral_notation : Environ.env -> Evd.evar_map -> locality_flag -> +val vernac_numeral_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> numnot_option -> unit diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index 5fae696d58..4234cee1bd 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -47,7 +47,9 @@ let type_error_of g ty = (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)).") -let vernac_string_notation env sigma local ty f g scope = +let vernac_string_notation local ty f g scope = + let env = Global.env () in + let sigma = Evd.from_env env in let app x y = mkAppC (x,[y]) in let cref q = mkRefC q in let cbyte = cref (q_byte ()) in diff --git a/plugins/syntax/string_notation.mli b/plugins/syntax/string_notation.mli index e81de603d9..1e25758572 100644 --- a/plugins/syntax/string_notation.mli +++ b/plugins/syntax/string_notation.mli @@ -13,6 +13,6 @@ open Vernacexpr (** * String notation *) -val vernac_string_notation : Environ.env -> Evd.evar_map -> locality_flag -> +val vernac_string_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> unit diff --git a/pretyping/cases.ml b/pretyping/cases.ml index d7a6c4c832..fadf290d44 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -824,7 +824,7 @@ let push_alias_eqn sigma alias eqn = (**********************************************************************) (* Functions to deal with elimination predicate *) -(* Infering the predicate *) +(* Inferring the predicate *) (* The problem to solve is the following: @@ -1455,7 +1455,7 @@ let compile ~program_mode sigma pb = (* Building the sub-problem when all patterns are variables. Case - where [current] is an intially pushed term. *) + where [current] is an initially pushed term. *) and shift_problem ((current,t),_,na) sigma pb = let ty = type_of_tomatch t in let tomatch = lift_tomatch_stack 1 pb.tomatch in @@ -1542,7 +1542,7 @@ let compile ~program_mode sigma pb = mat = List.map drop_alias_eqn pb.mat } in compile sigma pb in - (* If the "match" was orginally over a variable, as in "match x with + (* If the "match" was originally over a variable, as in "match x with O => true | n => n end", we give preference to non-expansion in the default clause (i.e. "match x with O => true | n => n end" rather than "match x with O => true | S p => S p end"; @@ -2067,7 +2067,7 @@ let prepare_predicate ?loc ~program_mode typing_fun env sigma tomatchs arsign ty let p2 = prepare_predicate_from_arsign_tycon ~program_mode env sigma loc tomatchs arsign t in (* Third strategy: we take the type constraint as it is; of course we could *) - (* need something inbetween, abstracting some but not all of the dependencies *) + (* need something in between, abstracting some but not all of the dependencies *) (* the "inversion" strategy deals with that but unification may not be *) (* powerful enough so strategy 2 and 3 helps; moreover, inverting does not *) (* work (yet) when a constructor has a type not precise enough for the inversion *) diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 5ea9b79336..4aa55e4d0d 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -477,7 +477,7 @@ and cbv_stack_value info env = function cbv_stack_value info env (CONSTR(c, [||]), stack_app args stk) | Some v -> cbv_stack_value info env (v,stk) | None -> mkSTACK(PRIMITIVE(op,c,args), stk) - else (* partical application *) + else (* partial application *) (assert (stk = TOP); PRIMITIVE(op,c,appl)) 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/evarconv.mli b/pretyping/evarconv.mli index eae961714d..04f54a1ad4 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -34,7 +34,7 @@ exception UnableToUnify of evar_map * Pretype_errors.unification_error ([unify_delay]) and another that tries to solve such remaining constraints using heuristics ([unify]). *) -(** Theses functions allow to pass arbitrary flags to the unifier and can delay constraints. +(** These functions allow to pass arbitrary flags to the unifier and can delay constraints. In case the flags are not specified, they default to [default_flags_of TransparentState.full] currently. diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4a941a68b1..c8b1c62db0 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -284,9 +284,9 @@ let noccur_evar env evd evk c = in try occur_rec false (0,env) c; true with Occur -> false -(***************************************) -(* Managing chains of local definitons *) -(***************************************) +(****************************************) +(* Managing chains of local definitions *) +(****************************************) type alias = | RelAlias of int @@ -629,7 +629,7 @@ let solve_pattern_eqn env sigma l c = * If a variable and an alias of it are bound to the same instance, we skip * the alias (we just use eq_constr -- instead of conv --, since anyway, * only instances that are variables -- or evars -- are later considered; - * morever, we can bet that similar instances came at some time from + * moreover, we can bet that similar instances came at some time from * the very same substitution. The removal of aliased duplicates is * useful to ensure the uniqueness of a projection. *) @@ -1738,7 +1738,7 @@ let reconsider_unif_constraints unify flags evd = * Returns an optional list of evars that were instantiated, or None * if the problem couldn't be solved. *) -(* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *) +(* Rq: incomplete algorithm if pbty = CONV_X_LEQ ! *) let solve_simple_eqn unify flags ?(choose=false) ?(imitate_defs=true) env evd (pbty,(evk1,args1 as ev1),t2) = try diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index cdd36bbba6..bfe3423b11 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -40,7 +40,7 @@ type t val make : hypnaming:naming_mode -> env -> evar_map -> ltac_var_map -> t -(** Export the underlying environement *) +(** Export the underlying environment *) val env : t -> env 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/indrec.ml b/pretyping/indrec.ml index 7615a17514..1c488a6974 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -84,7 +84,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let () = if Option.is_empty projs then check_privacy_block mib in let () = - if not (Sorts.List.mem kind (elim_sorts specif)) then + if not (Sorts.family_leq kind (elim_sort specif)) then raise (RecursionSchemeError (env, NotAllowedCaseAnalysis (false, fst (UnivGen.fresh_sort_in_family kind), pind))) @@ -557,8 +557,8 @@ let weaken_sort_scheme env evd set sort npars term ty = let check_arities env listdepkind = let _ = List.fold_left (fun ln (((_,ni as mind),u),mibi,mipi,dep,kind) -> - let kelim = elim_sorts (mibi,mipi) in - if not (Sorts.List.mem kind kelim) then raise + let kelim = elim_sort (mibi,mipi) in + if not (Sorts.family_leq kind kelim) then raise (RecursionSchemeError (env, NotAllowedCaseAnalysis (true, fst (UnivGen.fresh_sort_in_family kind),(mind,u)))) else if Int.List.mem ni ln then raise diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index b1c98da2c7..12a7859b88 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -255,10 +255,13 @@ let inductive_has_local_defs env ind = let l2 = mib.mind_nparams + mip.mind_nrealargs in not (Int.equal l1 l2) -let allowed_sorts env (kn,i as ind) = +let top_allowed_sort env (kn,i as ind) = let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_kelim +let sorts_below top = + List.filter (fun s -> Sorts.family_leq s top) Sorts.[InSProp;InProp;InSet;InType] + let has_dependent_elim mib = match mib.mind_record with | PrimRecord _ -> mib.mind_finite == BiFinite diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index cfc650938e..aacbecf6c7 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -141,7 +141,9 @@ val constructor_nrealdecls_env : env -> constructor -> int val constructor_has_local_defs : env -> constructor -> bool val inductive_has_local_defs : env -> inductive -> bool -val allowed_sorts : env -> inductive -> Sorts.family list +val sorts_below : Sorts.family -> Sorts.family list + +val top_allowed_sort : env -> inductive -> Sorts.family (** (Co)Inductive records with primitive projections do not have eta-conversion, hence no dependent elimination. *) 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/pretype_errors.mli b/pretyping/pretype_errors.mli index a9e2b0ea8f..25e56602a5 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -107,7 +107,7 @@ val error_ill_typed_rec_body : val error_elim_arity : ?loc:Loc.t -> env -> Evd.evar_map -> pinductive -> constr -> - unsafe_judgment -> (Sorts.family list * Sorts.family * Sorts.family * arity_error) option -> 'b + unsafe_judgment -> (Sorts.family * Sorts.family * Sorts.family * arity_error) option -> 'b val error_not_a_type : ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b 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/pretyping/program.mli b/pretyping/program.mli index a8f5115788..2614e181d6 100644 --- a/pretyping/program.mli +++ b/pretyping/program.mli @@ -11,7 +11,7 @@ open Names open EConstr -(** A bunch of Coq constants used by Progam *) +(** A bunch of Coq constants used by Program *) val sig_typ : unit -> GlobRef.t val sig_intro : unit -> GlobRef.t diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 85e6f51387..2fc9dc2776 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -886,7 +886,7 @@ module CredNative = RedNative(CNativeEntries) (** Generic reduction function with environment Here is where unfolded constant are stored in order to be - eventualy refolded. + eventually refolded. If tactic_mode is true, it uses ReductionBehaviour, prefers refold constant instead of value and tries to infer constants @@ -1315,7 +1315,7 @@ let whd_allnolet_stack env = let whd_allnolet env = red_of_state_red (whd_allnolet_state env) -(* 4. Ad-hoc eta reduction, does not subsitute evars *) +(* 4. Ad-hoc eta reduction, does not substitute evars *) let shrink_eta c = Stack.zip Evd.empty (local_whd_state_gen eta Evd.empty (c,Stack.empty)) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index ee27aea93f..26801d285e 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -62,7 +62,7 @@ type typeclass = { (* Context of definitions and properties on defs, will not be shared *) cl_props : Constr.rel_context; - (* The method implementaions as projections. *) + (* The method implementations as projections. *) cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; diff --git a/pretyping/typing.ml b/pretyping/typing.ml index be71f44a5e..00c52e7665 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -117,12 +117,12 @@ let check_branch_types env sigma (ind,u) cj (lfj,explft) = sigma lfj explft let max_sort l = - if Sorts.List.mem InType l then InType else - if Sorts.List.mem InSet l then InSet else InProp + if List.mem_f Sorts.family_equal InType l then InType else + if List.mem_f Sorts.family_equal InSet l then InSet else InProp let is_correct_arity env sigma c pj ind specif params = let arsign = make_arity_signature env sigma true (make_ind_family (ind,params)) in - let allowed_sorts = elim_sorts specif in + let allowed_sorts = sorts_below (elim_sort specif) in let error () = Pretype_errors.error_elim_arity env sigma ind c pj None in let rec srec env sigma pt ar = let pt' = whd_all env sigma pt in @@ -135,7 +135,7 @@ let is_correct_arity env sigma c pj ind specif params = end | Sort s, [] -> let s = ESorts.kind sigma s in - if not (Sorts.List.mem (Sorts.family s) allowed_sorts) + if not (List.mem_f Sorts.family_equal (Sorts.family s) allowed_sorts) then error () else sigma, s | Evar (ev,_), [] -> @@ -199,13 +199,13 @@ let check_type_fixpoint ?loc env sigma lna lar vdefj = (* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = let specif = lookup_mind_specif env (fst ind) in - let sorts = elim_sorts specif in + let sorts = elim_sort specif in let pj = Retyping.get_judgment_of env sigma p in let _, s = splay_prod env sigma pj.uj_type in let ksort = match EConstr.kind sigma s with | Sort s -> Sorts.family (ESorts.kind sigma s) | _ -> error_elim_arity env sigma ind c pj None in - if not (List.exists ((==) ksort) sorts) then + if not (Sorts.family_leq ksort sorts) then let s = inductive_sort_family (snd specif) in error_elim_arity env sigma ind c pj (Some(sorts,ksort,s,Type_errors.error_elim_explain ksort s)) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index d134c7319f..ad69cb2890 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1219,12 +1219,12 @@ let merge_instances env sigma flags st1 st2 c1 c2 = * bindings. This may or may not close off all RHSs of * the EVARs. For each EVAR whose RHS is closed off, * we can just apply it, and go on. For each which - * is not closed off, we need to do a mimick step - + * is not closed off, we need to do a mimic step - * in general, we have something like: * * ?X == (c e1 e2 ... ei[Meta(k)] ... en) * - * so we need to do a mimick step, converting ?X + * so we need to do a mimic step, converting ?X * into * * ?X -> (c ?z1 ... ?zn) @@ -1247,7 +1247,7 @@ let merge_instances env sigma flags st1 st2 c1 c2 = * we can reverse the equation, put it into our metavar * substitution, and keep going. * - * The most efficient mimick possible is, for each + * The most efficient mimic possible is, for each * Meta-var remaining in the term, to declare a * new EVAR of the same type. This is supposedly * determinable from the clausale form context - diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 78733784a7..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) @@ -249,7 +241,7 @@ let tag_var = tag Tag.variable str"@{" ++ hov 0 (prlist_with_sep pr_semicolon f (List.rev l)) ++ str"}")) let las = lapp - let lpator = 100 + let lpator = 0 let lpatrec = 0 let rec pr_patt sep inh p = @@ -283,7 +275,8 @@ let tag_var = tag Tag.variable pr_reference r, latom | CPatOr pl -> - hov 0 (prlist_with_sep pr_spcbar (pr_patt mt (lpator,L)) pl), lpator + let pp = pr_patt mt (lpator,Any) in + surround (hov 0 (prlist_with_sep pr_spcbar pp pl)), lpator | CPatNotation ((_,"( _ )"),([p],[]),[]) -> pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom @@ -339,8 +332,7 @@ let tag_var = tag Tag.variable let pr_binder many pr (nal,k,t) = match k with - | Generalized (b, b', t') -> - assert (match b with Implicit -> true | _ -> false); + | Generalized (b', t') -> begin match nal with |[{loc; v=Anonymous}] -> hov 1 (str"`" ++ (surround_impl b' @@ -349,7 +341,7 @@ let tag_var = tag Tag.variable hov 1 (str "`" ++ (surround_impl b' (pr_lident CAst.(make ?loc id) ++ str " : " ++ (if t' then str "!" else mt()) ++ pr t))) - |_ -> anomaly (Pp.str "List of generalized binders have alwais one element.") + |_ -> anomaly (Pp.str "List of generalized binders have always one element.") end | Default b -> match t with 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 9541ea5882..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 *) @@ -549,7 +555,7 @@ let print_instance sigma cb = let print_constant with_values sep sp udecl = let cb = Global.lookup_constant sp in - let val_0 = Global.body_of_constant_body cb in + let val_0 = Global.body_of_constant_body Library.indirect_accessor cb in let typ = cb.const_type in let univs = let open Univ in @@ -557,7 +563,7 @@ let print_constant with_values sep sp udecl = match cb.const_body with | Undef _ | Def _ | Primitive _ -> cb.const_universes | OpaqueDef o -> - let body_uctxs = Opaqueproof.force_constraints otab o in + let body_uctxs = Opaqueproof.force_constraints Library.indirect_accessor otab o in match cb.const_universes with | Monomorphic ctx -> Monomorphic (ContextSet.union body_uctxs ctx) @@ -717,7 +723,7 @@ let print_full_pure_context env sigma = | OpaqueDef lc -> str "Theorem " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype_env env sigma typ ++ str "." ++ fnl () ++ - str "Proof " ++ pr_lconstr_env env sigma (Opaqueproof.force_proof (Global.opaque_tables ()) lc) + str "Proof " ++ pr_lconstr_env env sigma (Opaqueproof.force_proof Library.indirect_accessor (Global.opaque_tables ()) lc) | Def c -> str "Definition " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype_env env sigma typ ++ cut () ++ str " := " ++ @@ -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/printing/proof_diffs.ml b/printing/proof_diffs.ml index f378a5d2dd..abb0d55b39 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -408,7 +408,7 @@ the call to db_goal_map and entering the following: let match_goals ot nt = let nevar_to_oevar = ref StringMap.empty in (* ogname is "" when there is no difference on the current path. - It's set to the old goal's evar name once a rewitten goal is found, + It's set to the old goal's evar name once a rewritten goal is found, at which point the code only searches for the replacing goals (and ot is set to nt). *) let iter2 f l1 l2 = diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index c36b0fa337..b022f4596d 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -19,7 +19,7 @@ open Reduction open Clenv (* This function put casts around metavariables whose type could not be - * infered by the refiner, that is head of applications, predicates and + * inferred by the refiner, that is head of applications, predicates and * subject of Cases. * Does check that the casted type is closed. Anyway, the refiner would * fail in this case... *) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 52e15f466f..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 @@ -142,12 +142,11 @@ let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = let gk = Global, poly, Proof Theorem in let ce, status, univs = build_constant_by_tactic id sigma sign ~goal_kind:gk typ tac in - let ce = - if side_eff then Safe_typing.inline_private_constants_in_definition_entry env ce - else { ce with - const_entry_body = Future.chain ce.const_entry_body - (fun (pt, _) -> pt, ()) } in - let (cb, ctx), () = Future.force ce.const_entry_body in + let body = Future.force ce.const_entry_body in + let (cb, ctx) = + if side_eff then Safe_typing.inline_private_constants env body + else fst body + in let univs = UState.merge ~sideff:side_eff ~extend:true Evd.univ_rigid univs ctx in cb, status, univs @@ -197,5 +196,5 @@ let refine_by_tactic ~name ~poly env sigma ty tac = other goals that were already present during its invocation, so that those goals rely on effects that are not present anymore. Hopefully, this hack will work in most cases. *) - let ans = Safe_typing.inline_private_constants_in_constr env ans neff in + let (ans, _) = Safe_typing.inline_private_constants env ((ans, Univ.ContextSet.empty), neff) in ans, sigma 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/proofs/refine.mli b/proofs/refine.mli index 55dafe521f..b8948a92f3 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -9,7 +9,7 @@ (************************************************************************) (** The primitive refine tactic used to fill the holes in partial proofs. This - is the recommanded way to write tactics when the proof term is easy to + is the recommended way to write tactics when the proof term is easy to write down. Note that this is not the user-level refine tactic defined in Ltac which is actually based on the one below. *) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index bce227dabb..799f4a380b 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -289,7 +289,7 @@ let tclIFTHENTRYELSEMUST tac1 tac2 gl = (* Fails if a tactic did not solve the goal *) let tclCOMPLETE tac = tclTHEN tac (tclFAIL_s "Proof is not complete.") -(* Try the first thats solves the current goal *) +(* Try the first that solves the current goal *) let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) 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 6f7cefb582..5baa6ce251 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -100,6 +100,15 @@ let forward_feedback, forward_feedback_hook = let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun ~doc:_ _ _ -> ()) () +let document_add, document_add_hook = Hook.make + ~default:(fun _ _ -> ()) () + +let document_edit, document_edit_hook = Hook.make + ~default:(fun _ -> ()) () + +let sentence_exec, sentence_exec_hook = Hook.make + ~default:(fun _ -> ()) () + include Hook (* enables: Hooks.(call foo args) *) @@ -571,7 +580,7 @@ end = struct (* {{{ *) (match Vernacprop.under_control x with | VernacDefinition (_,({CAst.v=Name i},_),_) -> Id.to_string i | VernacStartTheoremProof (_,[({CAst.v=i},_),_]) -> Id.to_string i - | VernacInstance (_,(({CAst.v=Name i},_),_,_),_,_) -> Id.to_string i + | VernacInstance (({CAst.v=Name i},_),_,_,_,_) -> Id.to_string i | _ -> "branch") let edit_branch = Branch.make "edit" let branch ?root ?pos name kind = vcs := branch !vcs ?root ?pos name kind @@ -872,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 *) @@ -1051,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... *) @@ -1163,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 *****************************************) (******************************************************************************) @@ -1256,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 = @@ -1725,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 @@ -1810,17 +1724,16 @@ end = struct (* {{{ *) str (Printexc.to_string e))); if drop then `ERROR_ADMITTED else `ERROR - let finish_task name (u,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") else Printf.sprintf ", bucket %d" bucket in match check_task_aux bucket_name name l i with | `ERROR -> exit 1 - | `ERROR_ADMITTED -> u, cst, false - | `OK_ADMITTED -> u, cst, false + | `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 @@ -1828,22 +1741,19 @@ end = struct (* {{{ *) let o = match c.Declarations.const_body with | Declarations.OpaqueDef o -> o | _ -> assert false in - let uc = - Option.get - (Opaqueproof.get_constraints (Global.opaque_tables ()) o) in + (* No need to delay the computation, the future has been forced by + 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 = - Future.from_val (map (Option.get (Global.body_of_constant_body c))) in - let uc = - Future.chain uc Univ.hcons_universe_context_set in - let pr = Future.chain pr discharge in - let pr = Future.chain pr Constr.hcons in - Future.sink pr; - let extra = Future.join uc in - u.(bucket) <- uc; - p.(bucket) <- pr; - u, Univ.ContextSet.union cst extra, false + let () = assert (Univ.AUContext.is_empty ctx) in + let pr = Constr.hcons pr in + 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 = match check_task_aux "" name l i with @@ -2652,16 +2562,16 @@ end (* }}} *) (********************************* STM API ************************************) (******************************************************************************) -(* Main initalization routine *) +(* Main initialization routine *) type stm_init_options = { (* The STM will set some internal flags differently depending on the - specified [doc_type]. This distinction should dissappear at some + specified [doc_type]. This distinction should disappear at some some point. *) doc_type : stm_doc_type; (* Initial load path in scope for the document. Usually extracted from -R options / _CoqProject *) - iload_path : Mltop.coq_path list; + iload_path : Loadpath.coq_path list; (* Require [require_libs] before the initial state is ready. Parameters follow [Library], that is to say, @@ -2693,8 +2603,8 @@ let dirpath_of_file f = Loadpath.logical lp with Not_found -> Libnames.default_root_prefix in - let file = Filename.chop_extension (Filename.basename f) in - let id = Id.of_string file in + let f = try Filename.chop_extension (Filename.basename f) with Invalid_argument _ -> f in + let id = Id.of_string f in let ldir = Libnames.add_dirpath_suffix ldir0 id in ldir @@ -2719,7 +2629,7 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = (* Set load path; important, this has to happen before we declare the library below as [Declaremods/Library] will infer the module name by looking at the load path! *) - List.iter Mltop.add_coq_path iload_path; + List.iter Loadpath.add_coq_path iload_path; Safe_typing.allow_delayed_constants := !cur_opt.async_proofs_mode <> APoff; @@ -2767,6 +2677,7 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = doc, VCS.cur_tip () let observe ~doc id = + Hooks.(call sentence_exec id); let vcs = VCS.backup () in try Reach.known_state ~doc ~cache:(VCS.is_interactive ()) id; @@ -2837,16 +2748,16 @@ 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 - let u, a, _ = List.fold_left finish_task u (info_tasks tasks) in - (u,a,true), p + let a, _ = List.fold_left finish_task u (info_tasks tasks) in + (a,true), p with e -> let e = CErrors.push e in msg_warning (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e); @@ -3107,7 +3018,7 @@ let ind_len_loc_of_id sid = let compute_indentation ?loc sid = Option.cata (fun loc -> let open Loc in - (* The effective lenght is the lenght on the last line *) + (* The effective length is the length on the last line *) let len = loc.ep - loc.bp in let prev_indent = match ind_len_loc_of_id sid with | None -> 0 @@ -3122,6 +3033,7 @@ let compute_indentation ?loc sid = Option.cata (fun loc -> ) (0, 0) loc let add ~doc ~ontop ?newtip verb ast = + Hooks.(call document_add ast ontop); let loc = ast.CAst.loc in let cur_tip = VCS.cur_tip () in if not (Stateid.equal ontop cur_tip) then @@ -3167,6 +3079,7 @@ let query ~doc ~at ~route s = s let edit_at ~doc id = + Hooks.(call document_edit id); if Stateid.equal id Stateid.dummy then anomaly(str"edit_at dummy.") else let vcs = VCS.backup () in let on_cur_branch id = @@ -3322,6 +3235,9 @@ let state_computed_hook = Hooks.state_computed_hook let state_ready_hook = Hooks.state_ready_hook let forward_feedback_hook = Hooks.forward_feedback_hook let unreachable_state_hook = Hooks.unreachable_state_hook +let document_add_hook = Hooks.document_add_hook +let document_edit_hook = Hooks.document_edit_hook +let sentence_exec_hook = Hooks.sentence_exec_hook let () = Hook.set Obligations.stm_get_fix_exn (fun () -> !State.fix_exn_ref) type document = VCS.vcs diff --git a/stm/stm.mli b/stm/stm.mli index 9d2bf56629..86e2566539 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -50,7 +50,7 @@ type stm_doc_type = | VioDoc of string (* file path *) | Interactive of interactive_top (* module path *) -(** Coq initalization options: +(** Coq initialization options: - [doc_type]: Type of document being created. @@ -63,13 +63,13 @@ type stm_doc_type = *) type stm_init_options = { (* The STM will set some internal flags differently depending on the - specified [doc_type]. This distinction should dissappear at some + specified [doc_type]. This distinction should disappear at some some point. *) doc_type : stm_doc_type; (* Initial load path in scope for the document. Usually extracted from -R options / _CoqProject *) - iload_path : Mltop.coq_path list; + iload_path : Loadpath.coq_path list; (* Require [require_libs] before the initial state is ready. Parameters follow [Library], that is to say, @@ -86,7 +86,7 @@ type stm_init_options = { (** The type of a STM document *) type doc -(** [init_core] performs some low-level initalization; should go away +(** [init_core] performs some low-level initialization; should go away in future releases. *) val init_core : unit -> unit @@ -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 *) @@ -282,6 +282,19 @@ val state_ready_hook : (doc:doc -> Stateid.t -> unit) Hook.t (* Messages from the workers to the master *) val forward_feedback_hook : (Feedback.feedback -> unit) Hook.t +(* + * Hooks into the UI for plugins (not for general use) + *) + +(** User adds a sentence to the document (after parsing) *) +val document_add_hook : (Vernacexpr.vernac_control -> Stateid.t -> unit) Hook.t + +(** User edits a sentence in the document *) +val document_edit_hook : (Stateid.t -> unit) Hook.t + +(** User requests evaluation of a sentence *) +val sentence_exec_hook : (Stateid.t -> unit) Hook.t + val get_doc : Feedback.doc_id -> doc val state_of_id : doc:doc -> diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 7cecd801e4..aa16f9535d 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -188,11 +188,11 @@ let classify_vernac e = | VernacDeclareMLModule _ | VernacContext _ (* TASSI: unsure *) -> VtSideff [], VtNow | VernacProofMode pm -> VtProofMode pm, VtNow - | VernacInstance (_,((name,_),_,_),None,_) when not (Attributes.parse_drop_extra Attributes.program atts) -> + | VernacInstance ((name,_),_,_,None,_) when not (Attributes.parse_drop_extra Attributes.program atts) -> let polymorphic = Attributes.(parse_drop_extra polymorphic atts) in let guarantee = if polymorphic then Doesn'tGuaranteeOpacity else GuaranteesOpacity in VtStartProof (guarantee, idents_of_name name.CAst.v), VtLater - | VernacInstance (_,((name,_),_,_),_,_) -> + | VernacInstance ((name,_),_,_,_,_) -> VtSideff (idents_of_name name.CAst.v), VtLater (* Stm will install a new classifier to handle these *) | VernacBack _ | VernacAbortAll 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/abstract.ml b/tactics/abstract.ml index 6dd9a976f9..a5b2f99457 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -99,7 +99,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = (* This is important: The [Global] and [Proof Theorem] parts of the goal_kind are not relevant here as build_constant_by_tactic does use the noop terminator; but beware if some day we remove the - redundancy on constrant declaration. This opens up an interesting + redundancy on constant declaration. This opens up an interesting question, how does abstract behave when discharge is local for example? *) let goal_kind, suffix = if opaque @@ -164,7 +164,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let inst = match const.Entries.const_entry_universes with | Entries.Monomorphic_entry _ -> EInstance.empty | Entries.Polymorphic_entry (_, ctx) -> - (* We mimick what the kernel does, that is ensuring that no additional + (* We mimic what the kernel does, that is ensuring that no additional constraints appear in the body of polymorphic constants. Ideally this should be enforced statically. *) let (_, body_uctx), _ = Future.force const.Entries.const_entry_body in diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 51708670f5..4b1b473b33 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -75,7 +75,9 @@ let find_matches bas pat = let res = HintDN.search_pattern base pat in List.map snd res -let print_rewrite_hintdb env sigma bas = +let print_rewrite_hintdb bas = + let env = Global.env () in + let sigma = Evd.from_env env in (str "Database " ++ str bas ++ fnl () ++ prlist_with_sep fnl (fun h -> diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 03e9414e0f..4c6146d745 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -42,7 +42,7 @@ val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> uni val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic -val print_rewrite_hintdb : Environ.env -> Evd.evar_map -> string -> Pp.t +val print_rewrite_hintdb : string -> Pp.t open Clenv diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 1fae4c3d9d..1170c1acd0 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -30,7 +30,7 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = if check_scheme kind ind then (* in case the inductive has a type elimination, generates only one induction scheme, the other ones share the same code with the - apropriate type *) + appropriate type *) let cte, eff = find_scheme kind ind in let sigma, cte = Evd.fresh_constant_instance env sigma cte in let c = mkConstU cte in diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index e75a61d0c6..1a0b7f84cf 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -30,7 +30,7 @@ open Proofview.Notations open Tacmach.New open Tactypes -(* This file containts the implementation of the tactics ``Decide +(* This file contains the implementation of the tactics ``Decide Equality'' and ``Compare''. They can be used to decide the propositional equality of two objects that belongs to a small inductive datatype --i.e., an inductive set such that all the diff --git a/tactics/equality.ml b/tactics/equality.ml index 45a4799ea1..51eee2a053 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -735,7 +735,7 @@ let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = let project env sorts posn t1 t2 = let ty1 = get_type_of env sigma t1 in let s = get_sort_family_of ~truncation_style:true env sigma ty1 in - if Sorts.List.mem s sorts + if List.mem_f Sorts.family_equal s sorts then [(List.rev posn,t1,t2)] else [] in let rec findrec sorts posn t1 t2 = @@ -746,7 +746,7 @@ let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = when Int.equal (List.length args1) (constructor_nallargs env sp1) -> let sorts' = - Sorts.List.intersect sorts (allowed_sorts env (fst sp1)) + CList.intersect Sorts.family_equal sorts (sorts_below (top_allowed_sort env (fst sp1))) in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) @@ -762,7 +762,7 @@ let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = List.flatten (List.map2_i (fun i -> findrec sorts' ((sp1,adjust i)::posn)) 0 rargs1 rargs2) - else if Sorts.List.mem InType sorts' && not no_discr + else if List.mem_f Sorts.family_equal InType sorts' && not no_discr then (* see build_discriminator *) raise (DiscrFound (List.rev posn,sp1,sp2)) else diff --git a/tactics/equality.mli b/tactics/equality.mli index 6f3e08ea02..7381d5f77b 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -132,7 +132,7 @@ val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic (* Replace term *) (* [replace_term dir_opt c cl] - perfoms replacement of [c] by the first value found in context + performs replacement of [c] by the first value found in context (according to [dir] if given to get the rewrite direction) in the clause [cl] *) val replace_term : bool option -> constr -> clause -> unit Proofview.tactic diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index e1dad9ad20..5ac28cb9e2 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -25,7 +25,7 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration (* I implemented the following functions which test whether a term t - is an inductive but non-recursive type, a general conjuction, a + is an inductive but non-recursive type, a general conjunction, a general disjunction, or a type with no constructors. They are more general than matching with or_term, and_term, etc, diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index b8c3ddb0f0..696b11d9db 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -35,7 +35,7 @@ open Coqlib contained in the arguments of the application *) (** I implemented the following functions which test whether a term [t] - is an inductive but non-recursive type, a general conjuction, a + is an inductive but non-recursive type, a general conjunction, a general disjunction, or a type with no constructors. They are more general than matching with [or_term], [and_term], etc, diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 6efa1ece9c..8cc481e30e 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -98,7 +98,7 @@ let get_local_sign sign = in List.fold_right add_local lid nil_sign *) -(* returs the identifier of lid that was the latest declared in sign. +(* returns the identifier of lid that was the latest declared in sign. * (i.e. is the identifier id of lid such that * sign_length (sign_prefix id sign) > sign_length (sign_prefix id' sign) > * for any id'<>id in lid). diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index dcd63fe760..59fd8b37d6 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -481,7 +481,7 @@ module New = struct ) <*> tclUNIT res - (* Try the first thats solves the current goal *) + (* Try the first that solves the current goal *) let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) let tclPROGRESS t = diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 9dafa8bad9..191f00d104 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3019,14 +3019,14 @@ let specialize (c,lbind) ipat = (* We grab names used in product to remember them at re-abstracting phase *) let typ_of_c_hd = pf_get_type_of gl c_hd in let lprod, concl = decompose_prod_assum sigma typ_of_c_hd in - (* accumulator args: arguments to apply to c_hd: all infered + (* accumulator args: arguments to apply to c_hd: all inferred args + re-abstracted rels *) let rec rebuild_lambdas sigma lprd args hd l = match lprd , l with | _, [] -> sigma,applist (hd, (List.map (nf_evar sigma) args)) | Context.Rel.Declaration.LocalAssum(nme,_)::lp' , t::l' when occur_meta sigma t -> (* nme has not been resolved, let us re-abstract it. Same - name but type updated by instanciation of other args. *) + name but type updated by instantiation of other args. *) let sigma,new_typ_of_t = Typing.type_of clause.env sigma t in let r = Retyping.relevance_of_type env sigma new_typ_of_t in let liftedargs = List.map liftrel args in @@ -4292,7 +4292,7 @@ let induction_tac with_evars params indvars elim = let elimc = contract_letin_in_lam_header sigma elimc in let elimc = mkCast (elimc, DEFAULTcast, elimt) in let elimclause = Tacmach.New.pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in - (* elimclause' is built from elimclause by instanciating all args and params. *) + (* elimclause' is built from elimclause by instantiating all args and params. *) let elimclause' = recolle_clenv i params indvars elimclause gl in (* one last resolution (useless?) *) let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in 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_10176.v b/test-suite/bugs/closed/bug_10176.v new file mode 100644 index 0000000000..fdb0eb87a4 --- /dev/null +++ b/test-suite/bugs/closed/bug_10176.v @@ -0,0 +1,7 @@ +Class Foo (xxx:nat) := foo : nat. + +Lemma aa `{Foo} : nat. Abort. + +Fail Lemma xy (Foo:bool->Type) `{Foo} : nat. + +Fail Lemma yx (Fooo:bool->Type) `{Fooo} : nat. 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_2137.v b/test-suite/bugs/closed/bug_2137.v index b1f54b1766..981cc94dc1 100644 --- a/test-suite/bugs/closed/bug_2137.v +++ b/test-suite/bugs/closed/bug_2137.v @@ -3,7 +3,7 @@ The fsetdec tactic is sensitive to which way round the arguments to <> are. In the small, self-contained example below, it is able to solve the goal if it knows that "b <> a", but not if it knows that "a <> b". I would expect -it to be able to solve hte goal in either case. +it to be able to solve the goal in either case. I have coq r12238. diff --git a/test-suite/bugs/closed/bug_2603.v b/test-suite/bugs/closed/bug_2603.v index 371bfdc575..64c656a7a6 100644 --- a/test-suite/bugs/closed/bug_2603.v +++ b/test-suite/bugs/closed/bug_2603.v @@ -3,7 +3,7 @@ As noticed by A. Appel in bug #2603, module names and definition names used to be in the same namespace. But conflict with names of constructors (or 2nd mutual inductive...) used to not be checked -enough, leading to stange situations. +enough, leading to strange situations. - In 8.3pl3 we introduced checks that forbid uniformly the following situations. diff --git a/test-suite/bugs/closed/bug_3080.v b/test-suite/bugs/closed/bug_3080.v index 36ab7ff599..06719653fe 100644 --- a/test-suite/bugs/closed/bug_3080.v +++ b/test-suite/bugs/closed/bug_3080.v @@ -15,4 +15,4 @@ Notation " g ∘ f " := (compose g f) (at level 40, left associativity) : function_scope. Fail Check (fun x => x) ∘ (fun x => x). (* this [Check] should fail, as [function_scope] is not opened *) -Check compose ((fun x => x) ∘ (fun x => x)) (fun x => x). (* this check should succeed, as [function_scope] should be automatically bound in the arugments to [compose] *) +Check compose ((fun x => x) ∘ (fun x => x)) (fun x => x). (* this check should succeed, as [function_scope] should be automatically bound in the arguments to [compose] *) 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_4503.v b/test-suite/bugs/closed/bug_4503.v index 5162f352df..26731e3292 100644 --- a/test-suite/bugs/closed/bug_4503.v +++ b/test-suite/bugs/closed/bug_4503.v @@ -29,7 +29,7 @@ End ILogic. Set Printing Universes. -(* There is stil a problem if the class is universe polymorphic *) +(* There is still a problem if the class is universe polymorphic *) Section Embed_ILogic_Pre. Polymorphic Universes A T. Fail Context {A : Type@{A}} {ILA: ILogic.ILogic@{A} A}. diff --git a/test-suite/bugs/closed/bug_4720.v b/test-suite/bugs/closed/bug_4720.v index 704331e784..a870792c39 100644 --- a/test-suite/bugs/closed/bug_4720.v +++ b/test-suite/bugs/closed/bug_4720.v @@ -34,7 +34,7 @@ End WithModPriv. identical by the extraction. In Coq 8.5 and 8.6, the extractions of WithMod, WithDef, WithModPriv - were all causing Anomaly or Assert Failure. This shoud be fixed now. + were all causing Anomaly or Assert Failure. This should be fixed now. *) Require Extraction. 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/bugs/closed/bug_5123.v b/test-suite/bugs/closed/bug_5123.v index 17231bffcf..a4029aeee0 100644 --- a/test-suite/bugs/closed/bug_5123.v +++ b/test-suite/bugs/closed/bug_5123.v @@ -28,6 +28,6 @@ Goal True. opose (@vect_sigT_eqdec _ _ _ _) as H. Unshelve. all:cycle 3. - eapply existT. (*This does no typeclass resultion, which is correct.*) + eapply existT. (*This does no typeclass resolution, which is correct.*) Focus 5. Abort. diff --git a/test-suite/bugs/closed/bug_5149.v b/test-suite/bugs/closed/bug_5149.v index ae32217057..b56abfe42e 100644 --- a/test-suite/bugs/closed/bug_5149.v +++ b/test-suite/bugs/closed/bug_5149.v @@ -36,7 +36,7 @@ Proof. solve [ unshelve (subst; eapply interpf_SmartVarVar; eassumption) ] || fail "too early". Undo. - (** Implicitely at the dot. The first fails because unshelve adds a goal, and solve hence fails. The second has an ambiant unification problem that is solved after solve *) + (** Implicitly at the dot. The first fails because unshelve adds a goal, and solve hence fails. The second has an ambiant unification problem that is solved after solve *) Fail solve [ unshelve (eapply interpf_SmartVarVar; subst; eassumption) ]. solve [eapply interpf_SmartVarVar; subst; eassumption]. Undo. diff --git a/test-suite/bugs/closed/bug_808_2411.v b/test-suite/bugs/closed/bug_808_2411.v index 1169b2036b..9fe4c9d503 100644 --- a/test-suite/bugs/closed/bug_808_2411.v +++ b/test-suite/bugs/closed/bug_808_2411.v @@ -2,7 +2,7 @@ Section test. Variable n:nat. Lemma foo: 0 <= n. Proof. -(* declaring an Axiom during a proof makes it immediatly +(* declaring an Axiom during a proof makes it immediately usable, juste as a full Definition. *) Axiom bar : n = 1. rewrite bar. diff --git a/test-suite/dune b/test-suite/dune index cd33319fa4..041c181d66 100644 --- a/test-suite/dune +++ b/test-suite/dune @@ -22,6 +22,7 @@ ../doc/stdlib/index-list.html.template ; For the changelog test ../config/coq_config.py + (source_tree doc/changelog) (package coq) ; For fake_ide (package coqide-server) diff --git a/test-suite/interactive/ParalITP_smallproofs.v b/test-suite/interactive/ParalITP_smallproofs.v index 0d75d52a31..d2e6794c0b 100644 --- a/test-suite/interactive/ParalITP_smallproofs.v +++ b/test-suite/interactive/ParalITP_smallproofs.v @@ -14,7 +14,7 @@ (* 02110-1301 USA *) -(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith developement but are rather useful. +(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith development but are rather useful. *) Require Export ZArith. @@ -84,7 +84,7 @@ End projection. (*###########################################################################*) -(* Declaring some realtions on natural numbers for stepl and stepr tactics. *) +(* Declaring some relations on natural numbers for stepl and stepr tactics. *) (*###########################################################################*) Lemma le_stepl: forall x y z, le x y -> x=z -> le z y. @@ -173,7 +173,7 @@ Qed. (*###########################################################################*) -(* Declaring some realtions on integers for stepl and stepr tactics. *) +(* Declaring some relations on integers for stepl and stepr tactics. *) (*###########################################################################*) Lemma Zle_stepl: forall x y z, (x<=y)%Z -> x=z -> (z<=y)%Z. diff --git a/test-suite/micromega/bug_10158.v b/test-suite/micromega/bug_10158.v new file mode 100644 index 0000000000..2c8f798f12 --- /dev/null +++ b/test-suite/micromega/bug_10158.v @@ -0,0 +1,48 @@ +Require Import ZArith_base. +Require Import Coq.micromega.Lia. + +Open Scope Z_scope. + +Fixpoint fib (n: nat) : Z := + match n with + | O => 1 + | S O => 1 + | S (S n as p) => fib p + fib n + end. + +Axiom fib_47_computed: fib 47 = 2971215073. + +Lemma fib_bound: + fib 47 < 2 ^ 32. +Proof. + pose proof fib_47_computed. + lia. +Qed. + +Require Import Reals. +Require Import Coq.micromega.Lra. + +Open Scope R_scope. + +Fixpoint fibr (n: nat) : R := + match n with + | O => 1 + | S O => 1 + | S (S n as p) => fibr p + fibr n + end. + +Axiom fibr_47_computed: fibr 47 = 2971215073. + +Lemma fibr_bound: + fibr 47 < 2 ^ 32. +Proof. + pose proof fibr_47_computed. + lra. +Qed. + +Lemma fibr_bound': + fibr 47 < IZR (Z.pow_pos 2 32). +Proof. + pose proof fibr_47_computed. + lra. +Qed. diff --git a/test-suite/micromega/rsyntax.v b/test-suite/micromega/rsyntax.v index 02b98b562f..f02d93f911 100644 --- a/test-suite/micromega/rsyntax.v +++ b/test-suite/micromega/rsyntax.v @@ -57,15 +57,7 @@ Require Import Lia. Goal ( 1 ^ (2 + 2) = 1)%Z. Proof. - Fail lia. - reflexivity. -Qed. - -Instance DZplus : DeclaredConstant Z.add := {}. - -Goal ( 1 ^ (2 + 2) = 1)%Z. -Proof. - lia. + lia. (* exponent is a constant expr *) Qed. diff --git a/test-suite/misc/changelog.sh b/test-suite/misc/changelog.sh index 8b4a49e577..76eb0de5aa 100755 --- a/test-suite/misc/changelog.sh +++ b/test-suite/misc/changelog.sh @@ -1,15 +1,14 @@ -#!/bin/sh +#!/usr/bin/env bash -while read line; do - if [ "$line" = "is_a_released_version = False" ]; then +if grep -q -F "is_a_released_version = False" ../config/coq_config.py; then echo "This is not a released version: nothing to test." exit 0 - fi -done < ../config/coq_config.py +fi for d in ../doc/changelog/*; do if [ -d "$d" ]; then - if [ "$(ls $d/*.rst | wc -l)" != "1" ]; then + files=("$d"/*.rst) + if [ "${#files[@]}" != 1 ]; then echo "Fatal: unreleased changelog entries remain in ${d#../}/" echo "Include them in doc/sphinx/changes.rst and remove them from doc/changelog/" exit 1 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/output/MExtraction.v b/test-suite/output/MExtraction.v index 7429a521b3..c0ef9b392d 100644 --- a/test-suite/output/MExtraction.v +++ b/test-suite/output/MExtraction.v @@ -7,8 +7,8 @@ Require Import QMicromega. Require Import RMicromega. Recursive Extraction - Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - ZMicromega.cnfZ ZMicromega.bound_problem_fr QMicromega.cnfQ +Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula + ZMicromega.cnfZ ZMicromega.Zeval_const ZMicromega.bound_problem_fr QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index dcc8bd7165..29614c032a 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -209,7 +209,7 @@ Notation "'exists_mixed' x .. y , P" := (ex (fun x => forall z:nat, .. (ex (fun Check exists_mixed x y '(u,t), x+y=0/\u+t=0. Check exists_mixed x y '(z,t), x+y=0/\z+t=0. -(* Check that intermediary let-in are inserted inbetween instances of +(* Check that intermediary let-in are inserted in between instances of the repeated pattern *) Notation "'exists_true' x .. y , P" := (exists x, True /\ .. (exists y, True /\ P) ..) (at level 200, x binder). Check exists_true '(x,y) (u:=0) '(z,t), x+y=0/\z+t=0. diff --git a/test-suite/output/injection.out b/test-suite/output/injection.out new file mode 100644 index 0000000000..ff40a478f3 --- /dev/null +++ b/test-suite/output/injection.out @@ -0,0 +1,4 @@ +The command has indeed failed with message: +Unexpected pattern. +The command has indeed failed with message: +Unexpected injection pattern. diff --git a/test-suite/output/injection.v b/test-suite/output/injection.v new file mode 100644 index 0000000000..bfd5a67bf5 --- /dev/null +++ b/test-suite/output/injection.v @@ -0,0 +1,8 @@ +(* Test error messages *) + +Goal forall x, (x,0) = (0, S x) -> x = 0. +Fail intros x H; injection H as [= H'] H''. +Fail intros x H; injection H as H' [= H'']. +intros x H; injection H as [= H' H'']. +exact H'. +Qed. 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/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v index 3c427237b4..69ed621877 100644 --- a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v +++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v @@ -14,7 +14,7 @@ (* 02110-1301 USA *) -(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith developement but are rather useful. +(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith development but are rather useful. *) Require Export ZArith. @@ -84,7 +84,7 @@ End projection. (*###########################################################################*) -(* Declaring some realtions on natural numbers for stepl and stepr tactics. *) +(* Declaring some relations on natural numbers for stepl and stepr tactics. *) (*###########################################################################*) Lemma le_stepl: forall x y z, le x y -> x=z -> le z y. @@ -173,7 +173,7 @@ Qed. (*###########################################################################*) -(* Declaring some realtions on integers for stepl and stepr tactics. *) +(* Declaring some relations on integers for stepl and stepr tactics. *) (*###########################################################################*) Lemma Zle_stepl: forall x y z, (x<=y)%Z -> x=z -> (z<=y)%Z. 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/Case15.v b/test-suite/success/Case15.v index 69fca48e24..ba6bf3bba2 100644 --- a/test-suite/success/Case15.v +++ b/test-suite/success/Case15.v @@ -20,7 +20,7 @@ Definition test (B : Boite) := | boite false (n, m) => n + m end. -(* Check lazyness of compilation ... future work +(* Check laziness of compilation ... future work Inductive I : Set := c : (b:bool)(if b then bool else nat)->I. Check [x] diff --git a/test-suite/success/Case18.v b/test-suite/success/Case18.v index be9ca8d41b..6bea435090 100644 --- a/test-suite/success/Case18.v +++ b/test-suite/success/Case18.v @@ -1,7 +1,10 @@ (* Check or-patterns *) +(* Non-interference with Numbers divisibility. *) +Reserved Notation "( p | q )" (at level 0). + Definition g x := - match x with ((((1 as x),_) | (_,x)), (_,(2 as y))|(y,_)) => (x,y) end. + match x with ((((1 as x),_) | (_,x)), ((_,(2 as y)) | (y,_))) => (x,y) end. Check (refl_equal _ : g ((1,2),(3,4)) = (1,3)). diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v index 8d9edbd62d..02e15b8ee2 100644 --- a/test-suite/success/CasesDep.v +++ b/test-suite/success/CasesDep.v @@ -62,7 +62,7 @@ Check fun x:{_:{x:nat*nat|fst x = 0 & True}|True}+nat => match x return option n (* -------------------------------------------------------------------- *) (* Example to test patterns matching on dependent families *) -(* This exemple extracted from the developement done by Nacira Chabane *) +(* This exemple extracted from the development done by Nacira Chabane *) (* (equipe Paris 6) *) (* -------------------------------------------------------------------- *) @@ -298,7 +298,7 @@ End Version1. (* ------------------------------------------------------------------*) -(* Initial exemple (without patterns) *) +(* Initial example (without patterns) *) (*-------------------------------------------------------------------*) Module Version2. diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v index 2f13b7c225..e96a5f9048 100644 --- a/test-suite/success/Hints.v +++ b/test-suite/success/Hints.v @@ -175,7 +175,7 @@ End HintCut. (* Check that auto-like tactics do not prefer "eq_refl" over more complex solutions, *) -(* e.g. those tactics when considering a goal with existential varibles *) +(* e.g. those tactics when considering a goal with existential variables *) (* like "m = ?n" won't pick "plus_n_O" hint over "eq_refl" hint. *) (* See this Coq club post for more detail: *) (* https://sympa.inria.fr/sympa/arc/coq-club/2017-12/msg00103.html *) diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v index ee540d7109..1dbeaf3e1f 100644 --- a/test-suite/success/Inversion.v +++ b/test-suite/success/Inversion.v @@ -179,7 +179,7 @@ exact Logic.I. Qed. (* Up to September 2014, H0 below was renamed called H1 because of a collision - with the automaticallly generated names for equations. + with the automatically generated names for equations. (example taken from CoLoR) *) Inductive term := Var | Fun : term -> term -> term. diff --git a/test-suite/success/Reordering.v b/test-suite/success/Reordering.v index de9b997590..98759264e5 100644 --- a/test-suite/success/Reordering.v +++ b/test-suite/success/Reordering.v @@ -1,7 +1,7 @@ (* Testing the reordering of hypothesis required by pattern, fold and change. *) Goal forall (A:Set) (x:A) (A':=A), True. intros. -fold A' in x. (* suceeds: x is moved after A' *) +fold A' in x. (* succeeds: x is moved after A' *) Undo. pattern A' in x. Undo. diff --git a/test-suite/success/extraction_dep.v b/test-suite/success/extraction_dep.v index fb0adabae9..c566a6db9f 100644 --- a/test-suite/success/extraction_dep.v +++ b/test-suite/success/extraction_dep.v @@ -34,7 +34,7 @@ Definition testAbis := Abis.u + Abis.y. Recursive Extraction testAbis. (* without: A B v w x *) Extraction TestCompile testAbis. -(** 2) With signature, we only keep elements mentionned in signature. *) +(** 2) With signature, we only keep elements mentioned in signature. *) Module Type SIG. Parameter u : nat. diff --git a/test-suite/success/if.v b/test-suite/success/if.v index c81d2b9bf1..68d26ac8df 100644 --- a/test-suite/success/if.v +++ b/test-suite/success/if.v @@ -1,4 +1,4 @@ -(* The synthesis of the elimination predicate may fail if algebric *) +(* The synthesis of the elimination predicate may fail if algebraic *) (* universes are not cautiously treated *) Check (fun b : bool => if b then Type else nat). 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/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index ddbc128aa1..6a4a0445b5 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -53,7 +53,7 @@ destruct le_mn1; intros le_mn2; destruct le_mn2. now destruct (Nat.nle_succ_diag_l _ le_mn0). + intros def_n0; generalize le_mn1; rewrite def_n0; intros le_mn0. now destruct (Nat.nle_succ_diag_l _ le_mn0). -+ intros def_n0. injection def_n0 as ->. ++ intros def_n0. injection def_n0 as [= ->]. rewrite (UIP_nat _ _ def_n0 eq_refl); simpl. assert (H : le_mn1 = le_mn2). now apply IHn0. diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index c014ecc7ab..2dd254496b 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -337,7 +337,7 @@ Section Binary. morphism for equivalence (see Morphisms). It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) - Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R. + Global Instance partial_order_antisym `(PartialOrder eqA R) : Antisymmetric eqA R. Proof with auto. reduce_goal. apply H. firstorder. diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index e9a9d6aff2..8abd4a3cbb 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -76,7 +76,7 @@ Infix "<>b" := nequiv_decb (no associativity, at level 70). (** Decidable leibniz equality instances. *) -(** The equiv is burried inside the setoid, but we can recover it by specifying +(** The equiv is buried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) Program Instance nat_eq_eqdec : EqDec nat eq := eq_nat_dec. @@ -94,7 +94,7 @@ Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left. Obligation Tactic := unfold complement, equiv ; program_simpl. Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) : - ! EqDec (prod A B) eq := + EqDec (prod A B) eq := { equiv_dec x y := let '(x1, x2) := x in let '(y1, y2) := y in @@ -115,7 +115,7 @@ Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) : (** Objects of function spaces with countable domains like bool have decidable equality. Proving the reflection requires functional extensionality though. *) -Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq := +Program Instance bool_function_eqdec `(EqDec A eq) : EqDec (bool -> A) eq := { equiv_dec f g := if f true == g true then if f false == g false then in_left @@ -130,7 +130,7 @@ Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq := Require Import List. -Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq := +Program Instance list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq := { equiv_dec := fix aux (x y : list A) := match x, y with diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 440b317573..3c0982cde7 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -464,7 +464,7 @@ Section Binary. morphism for equivalence (see Morphisms). It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) - Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R. + Global Instance partial_order_antisym `(PartialOrder eqA R) : Antisymmetric A eqA R. Proof with auto. reduce_goal. pose proof partial_order_equivalence as poe. do 3 red in poe. @@ -481,7 +481,7 @@ Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : type (** The partial order defined by subrelation and relation equivalence. *) Program Instance subrelation_partial_order : - ! PartialOrder (relation A) relation_equivalence subrelation. + PartialOrder (@relation_equivalence A) subrelation. Next Obligation. Proof. diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index f6b240bf20..28394b984e 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -77,7 +77,7 @@ Infix "<>b" := nequiv_decb (no associativity, at level 70). Require Import Coq.Arith.Arith. -(** The equiv is burried inside the setoid, but we can recover +(** The equiv is buried inside the setoid, but we can recover it by specifying which setoid we're talking about. *) Program Instance eq_setoid A : Setoid A | 10 := diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index e68bc5930d..153842654a 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -1988,7 +1988,7 @@ Module OrdProperties (M:S). simpl; intros; try discriminate. intros. destruct a; destruct l; simpl in *. - injection H as -> ->. + injection H as [= -> ->]. inversion_clear H1. red in H; simpl in *; intuition. elim H0; eauto. @@ -2052,7 +2052,7 @@ Module OrdProperties (M:S). generalize (elements_3 m). destruct (elements m). try discriminate. - destruct p; injection H as -> ->; intros H4. + destruct p; injection H as [= -> ->]; intros H4. inversion_clear H1 as [? ? H2|? ? H2]. red in H2; destruct H2; simpl in *; ME.order. inversion_clear H4. rename H1 into H3. diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index 8970529103..a12e4a43c2 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -192,7 +192,7 @@ Module Type WSfun (E : DecidableType). (** Equality of maps *) (** Caveat: there are at least three distinct equality predicates on maps. - - The simpliest (and maybe most natural) way is to consider keys up to + - The simplest (and maybe most natural) way is to consider keys up to their equivalence [E.eq], but elements up to Leibniz equality, in the spirit of [eq_key_elt] above. This leads to predicate [Equal]. - Unfortunately, this [Equal] predicate can't be used to describe diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index b47c99244b..37dd2304da 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -277,7 +277,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. rewrite append_assoc_1; apply in_or_app; right; apply in_cons; apply IHm2; auto. rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto. - rewrite append_neutral_r; apply in_or_app; injection H as ->; + rewrite append_neutral_r; apply in_or_app; injection H as [= ->]; right; apply in_eq. rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto. rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto. @@ -318,7 +318,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply in_or_app. left; apply IHm1; auto. right; destruct (in_inv H0). - injection H1 as -> ->; apply in_eq. + injection H1 as [= -> ->]; apply in_eq. apply in_cons; apply IHm2; auto. left; apply IHm1; auto. right; apply IHm2; auto. @@ -349,7 +349,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply in_or_app. left; apply IHm1; auto. right; destruct (in_inv H0). - injection H1 as -> ->; apply in_eq. + injection H1 as [= -> ->]; apply in_eq. apply in_cons; apply IHm2; auto. left; apply IHm1; auto. right; apply IHm2; auto. @@ -692,7 +692,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst. red; red; simpl. destruct H0. - injection H0 as H0 _; subst. + injection H0 as [= H0 _]; subst. eapply xelements_bits_lt_1; eauto. apply E.bits_lt_trans with p. eapply xelements_bits_lt_1; eauto. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index 83bb07ffb6..d977ac05ec 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -240,7 +240,7 @@ the above form: True. Proof. intros. push not in *. - (* note that ~(R->P) remains (since R isnt decidable) *) + (* note that ~(R->P) remains (since R isn't decidable) *) tauto. Qed. diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v index 8a93f38164..d2e10e42a6 100644 --- a/theories/FSets/FSetPositive.v +++ b/theories/FSets/FSetPositive.v @@ -1009,10 +1009,10 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct o. intros x H. injection H; intros; subst. reflexivity. revert IHl. case choose. - intros p Hp x H. injection H as <-. apply Hp. + intros p Hp x [= <-]. apply Hp. reflexivity. intros _ x. revert IHr. case choose. - intros p Hp H. injection H as <-. apply Hp. + intros p Hp [= <-]. apply Hp. reflexivity. intros. discriminate. Qed. @@ -1068,11 +1068,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. induction s as [| l IHl o r IHr]; simpl. intros. discriminate. intros x. destruct (min_elt l); intros. - injection H as <-. apply IHl. reflexivity. + injection H as [= <-]. apply IHl. reflexivity. destruct o; simpl. - injection H as <-. reflexivity. + injection H as [= <-]. reflexivity. destruct (min_elt r); simpl in *. - injection H as <-. apply IHr. reflexivity. + injection H as [= <-]. apply IHr. reflexivity. discriminate. Qed. @@ -1096,15 +1096,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. induction s as [|l IHl o r IHr]; intros x y H H'. discriminate. simpl in H. case_eq (min_elt l). - intros p Hp. rewrite Hp in H. injection H as <-. + intros p Hp. rewrite Hp in H. injection H as [= <-]. destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial. intro Hp; rewrite Hp in H. apply min_elt_3 in Hp. destruct o. - injection H as <-. intros Hl. + injection H as [= <-]. intros Hl. destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). destruct (min_elt r). - injection H as <-. + injection H as [= <-]. destruct y as [z|z|]. apply (IHr e z); trivial. elim (Hp _ H'). @@ -1121,11 +1121,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. induction s as [| l IHl o r IHr]; simpl. intros. discriminate. intros x. destruct (max_elt r); intros. - injection H as <-. apply IHr. reflexivity. + injection H as [= <-]. apply IHr. reflexivity. destruct o; simpl. - injection H as <-. reflexivity. + injection H as [= <-]. reflexivity. destruct (max_elt l); simpl in *. - injection H as <-. apply IHl. reflexivity. + injection H as [= <-]. apply IHl. reflexivity. discriminate. Qed. @@ -1149,15 +1149,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. induction s as [|l IHl o r IHr]; intros x y H H'. discriminate. simpl in H. case_eq (max_elt r). - intros p Hp. rewrite Hp in H. injection H as <-. + intros p Hp. rewrite Hp in H. injection H as [= <-]. destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial. intro Hp; rewrite Hp in H. apply max_elt_3 in Hp. destruct o. - injection H as <-. intros Hl. + injection H as [= <-]. intros Hl. destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). destruct (max_elt l). - injection H as <-. + injection H as [= <-]. destruct y as [z|z|]. elim (Hp _ H'). apply (IHl e z); trivial. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 1a391ed799..d54c8bf42d 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -37,7 +37,7 @@ Notation "~ x" := (not x) : type_scope. Register not as core.not.type. (** Create the "core" hint database, and set its transparent state for - variables and constants explicitely. *) + variables and constants explicitly. *) Create HintDb core. Hint Variables Opaque : core. diff --git a/theories/Init/Nat.v b/theories/Init/Nat.v index 7e7a1ced58..5952f3a31b 100644 --- a/theories/Init/Nat.v +++ b/theories/Init/Nat.v @@ -331,7 +331,7 @@ Definition iter (n:nat) {A} (f:A->A) (x:A) : A := (** Bitwise operations *) (** We provide here some bitwise operations for unary numbers. - Some might be really naive, they are just there for fullfiling + Some might be really naive, they are just there for fulfilling the same interface as other for natural representations. As soon as binary representations such as NArith are available, it is clearly better to convert to/from them and use their ops. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 497cf2550b..7eb717787e 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -75,7 +75,7 @@ Ltac case_eq x := generalize (eq_refl x); pattern x at -1; case x. (* use either discriminate or injection on a hypothesis *) -Ltac destr_eq H := discriminate H || (try (injection H as H)). +Ltac destr_eq H := discriminate H || (try (injection H as [= H])). (* Similar variants of destruct *) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index a48e9929c4..f73440eb1a 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -250,7 +250,7 @@ Section Facts. generalize (app_nil_r l); intros E. rewrite -> E; auto. intros. - injection H as H H0. + injection H as [= H H0]. assert ([] = l ++ a0 :: l0) by auto. apply app_cons_not_nil in H1 as []. Qed. @@ -261,18 +261,14 @@ Section Facts. induction x as [| x l IHl]; [ destruct y as [| a l] | destruct y as [| a l0] ]; simpl; auto. - - intros a b H. - injection H. + - intros a b [= ]. auto. - - intros a0 b H. - injection H as H1 H0. + - intros a0 b [= H1 H0]. apply app_cons_not_nil in H0 as []. - - intros a b H. - injection H as H1 H0. + - intros a b [= H1 H0]. assert ([] = l ++ [a]) by auto. apply app_cons_not_nil in H as []. - - intros a0 b H. - injection H as <- H0. + - intros a0 b [= <- H0]. destruct (IHl l0 a0 b H0) as (<-,<-). split; auto. Qed. @@ -336,7 +332,7 @@ Section Facts. absurd (length (x1 :: l1 ++ l) <= length l). simpl; rewrite app_length; auto with arith. rewrite H; auto with arith. - injection H as H H0; f_equal; eauto. + injection H as [= H H0]; f_equal; eauto. Qed. End Facts. @@ -519,7 +515,7 @@ Section Elts. Proof. revert l. induction n as [|n IH]; intros [|x l] H; simpl in *; try easy. - - exists nil; exists l. now injection H as ->. + - exists nil; exists l. now injection H as [= ->]. - destruct (IH _ H) as (l1 & l2 & H1 & H2). exists (x::l1); exists l2; simpl; split; now f_equal. Qed. @@ -1243,7 +1239,7 @@ End Fold_Right_Recursor. Proof. induction l as [|a l IH]; simpl; [easy| ]. case_eq (f a); intros Ha Eq. - * injection Eq as ->; auto. + * injection Eq as [= ->]; auto. * destruct (IH Eq); auto. Qed. @@ -1304,10 +1300,10 @@ End Fold_Right_Recursor. forall x:A, In x l <-> In x l1 \/ In x l2. Proof. revert l1 l2. induction l as [| a l' Hrec]; simpl; intros l1 l2 Eq x. - - injection Eq as <- <-. tauto. + - injection Eq as [= <- <-]. tauto. - destruct (partition l') as (left, right). specialize (Hrec left right eq_refl x). - destruct (f a); injection Eq as <- <-; simpl; tauto. + destruct (f a); injection Eq as [= <- <-]; simpl; tauto. Qed. End Bool. @@ -1483,7 +1479,7 @@ End Fold_Right_Recursor. destruct (in_app_or _ _ _ H); clear H. destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_). destruct (H1 H0) as (z,(H2,H3)); clear H0 H1. - injection H2 as -> ->; intuition. + injection H2 as [= -> ->]; intuition. intuition. Qed. diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index 419a0be49c..e1e0d3db4c 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -70,7 +70,7 @@ Qed. End MemoFunction. (** For a dependent function, the previous solution is - reused thanks to a temporarly hiding of the dependency + reused thanks to a temporary hiding of the dependency in a "container" [memo_val]. *) Section DependentMemoFunction. diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index b06384e992..73d7432193 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -385,7 +385,7 @@ End Proof_irrelevance_EM_CC. fragment of [Prop] into [bool], hence weak classical logic, i.e. [forall A, ~A\/~~A], is enough for deriving a weak version of proof-irrelevance. This is enough to derive a contradiction from a - [Set]-bound weak excluded middle wih an impredicative [Set] + [Set]-bound weak excluded middle with an impredicative [Set] universe. *) Section Proof_irrelevance_WEM_CC. diff --git a/theories/Logic/WeakFan.v b/theories/Logic/WeakFan.v index c9822f47dc..13f63c5cbc 100644 --- a/theories/Logic/WeakFan.v +++ b/theories/Logic/WeakFan.v @@ -64,7 +64,7 @@ induction l1, l2. - discriminate. - discriminate. - intros H (HY1,H1) (HY2,H2). - injection H as H. + injection H as [= H]. pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1. subst l1. f_equal. diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v index f228cbb3bf..3ceff849be 100644 --- a/theories/MSets/MSetDecide.v +++ b/theories/MSets/MSetDecide.v @@ -240,7 +240,7 @@ the above form: True. Proof. intros. push not in *. - (* note that ~(R->P) remains (since R isnt decidable) *) + (* note that ~(R->P) remains (since R isn't decidable) *) tauto. Qed. diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index a3dcca7dfd..838721f499 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -166,7 +166,7 @@ end. *) (** Enumeration of the elements of a tree. This corresponds - to the "samefringe" notion in the litterature. *) + to the "samefringe" notion in the literature. *) #[universes(template)] Inductive enumeration := diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index 6a18f59fc4..85139593da 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -659,7 +659,7 @@ End Raw2Sets. (** It is in fact possible to provide an ordering on sets with very little information on them (more or less only the [In] predicate). This generic build of ordering is in fact not - used for the moment, we rather use a simplier version + used for the moment, we rather use a simpler version dedicated to sets-as-sorted-lists, see [MakeListOrdering]. *) diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v index a726eebd31..330c7959ac 100644 --- a/theories/MSets/MSetPositive.v +++ b/theories/MSets/MSetPositive.v @@ -910,10 +910,10 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. destruct o. intros x H. injection H; intros; subst. reflexivity. revert IHl. case choose. - intros p Hp x H. injection H as <-. apply Hp. + intros p Hp x [= <-]. apply Hp. reflexivity. intros _ x. revert IHr. case choose. - intros p Hp H. injection H as <-. apply Hp. + intros p Hp [= <-]. apply Hp. reflexivity. intros. discriminate. Qed. @@ -970,11 +970,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. induction s as [| l IHl o r IHr]; simpl. intros. discriminate. intros x. destruct (min_elt l); intros. - injection H as <-. apply IHl. reflexivity. + injection H as [= <-]. apply IHl. reflexivity. destruct o; simpl. - injection H as <-. reflexivity. + injection H as [= <-]. reflexivity. destruct (min_elt r); simpl in *. - injection H as <-. apply IHr. reflexivity. + injection H as [= <-]. apply IHr. reflexivity. discriminate. Qed. @@ -998,15 +998,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. induction s as [|l IHl o r IHr]; intros x y H H'. discriminate. simpl in H. case_eq (min_elt l). - intros p Hp. rewrite Hp in H. injection H as <-. + intros p Hp. rewrite Hp in H. injection H as [= <-]. destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial. intro Hp; rewrite Hp in H. apply min_elt_spec3 in Hp. destruct o. - injection H as <-. intros Hl. + injection H as [= <-]. intros Hl. destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). destruct (min_elt r). - injection H as <-. + injection H as [= <-]. destruct y as [z|z|]. apply (IHr e z); trivial. elim (Hp _ H'). @@ -1023,11 +1023,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. induction s as [| l IHl o r IHr]; simpl. intros. discriminate. intros x. destruct (max_elt r); intros. - injection H as <-. apply IHr. reflexivity. + injection H as [= <-]. apply IHr. reflexivity. destruct o; simpl. - injection H as <-. reflexivity. + injection H as [= <-]. reflexivity. destruct (max_elt l); simpl in *. - injection H as <-. apply IHl. reflexivity. + injection H as [= <-]. apply IHl. reflexivity. discriminate. Qed. @@ -1051,15 +1051,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. induction s as [|l IHl o r IHr]; intros x y H H'. discriminate. simpl in H. case_eq (max_elt r). - intros p Hp. rewrite Hp in H. injection H as <-. + intros p Hp. rewrite Hp in H. injection H as [= <-]. destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial. intro Hp; rewrite Hp in H. apply max_elt_spec3 in Hp. destruct o. - injection H as <-. intros Hl. + injection H as [= <-]. intros Hl. destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). destruct (max_elt l). - injection H as <-. + injection H as [= <-]. destruct y as [z|z|]. elim (Hp _ H'). apply (IHl e z); trivial. diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index f9105fdf74..a2ffd2050e 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -1950,7 +1950,7 @@ Module Make (X: Orders.OrderedType) <: generalize (fun x s' => @Raw.remove_min_spec1 s x s' Hs). set (P := Raw.remove_min_ok s). clearbody P. destruct (Raw.remove_min s) as [(x0,s0)|]; try easy. - intros H U. injection U as -> <-. simpl. + intros H [= -> <-]. simpl. destruct (H x s0); auto. subst; intuition. Qed. diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index be12fffaaf..3e5987127a 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -25,7 +25,7 @@ Module N. Definition t := N. -(** ** Nicer name [N.pos] for contructor [Npos] *) +(** ** Nicer name [N.pos] for constructor [Npos] *) Notation pos := Npos. diff --git a/theories/Numbers/AltBinNotations.v b/theories/Numbers/AltBinNotations.v index c7e3999691..6809154a33 100644 --- a/theories/Numbers/AltBinNotations.v +++ b/theories/Numbers/AltBinNotations.v @@ -18,7 +18,7 @@ thousands of digits and more, conversion from/to [Decimal.int] can become significantly slow. If that becomes a problem for your development, this file provides some alternative [Numeral - Notation] commmands that use [Z] as bridge type. To enable these + Notation] commands that use [Z] as bridge type. To enable these commands, just be sure to [Require] this file after other files defining numeral notations. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 4b0bda3d44..a7bc4211ed 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -1288,7 +1288,7 @@ Section Int31_Specs. intros; rewrite <- spec_1; apply spec_add. Qed. - (** Substraction *) + (** Subtraction *) Lemma spec_sub_c : forall x y, [-|sub31c x y|] = [|x|] - [|y|]. Proof. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index b9185c9ca0..10f819b005 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -255,7 +255,7 @@ Definition add31carryc (n m : int31) := | _ => C1 npmpone end. -(** * Substraction *) +(** * Subtraction *) (** Subtraction modulo [2^31] *) diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 4bcd22543f..94da55b3f3 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -372,7 +372,7 @@ Section ZModulo. assert (Z.div_eucl ([|x|]*[|y|]) wB = (([|x|]*[|y|])/wB,([|x|]*[|y|]) mod wB)). unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. generalize (Z_div_mod ([|x|]*[|y|]) wB wB_pos); destruct Z.div_eucl as (h,l). - destruct 1; injection H as ? ?. + destruct 1; injection H as [= ? ?]. rewrite H0. assert ([|l|] = l). apply Zmod_small; auto. @@ -414,7 +414,7 @@ Section ZModulo. unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. generalize (Z_div_mod [|a|] [|b|] H0). destruct Z.div_eucl as (q,r); destruct 1; intros. - injection H1 as ? ?. + injection H1 as [= ? ?]. assert ([|r|]=r). apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; auto with zarith. @@ -525,7 +525,7 @@ Section ZModulo. unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. generalize (Z_div_mod a [|b|] H3). destruct Z.div_eucl as (q,r); destruct 1; intros. - injection H4 as ? ?. + injection H4 as [= ? ?]. assert ([|r|]=r). apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; auto with zarith. diff --git a/theories/Numbers/Integer/Abstract/ZBits.v b/theories/Numbers/Integer/Abstract/ZBits.v index 4aabda77ee..42ea8f76fb 100644 --- a/theories/Numbers/Integer/Abstract/ZBits.v +++ b/theories/Numbers/Integer/Abstract/ZBits.v @@ -324,7 +324,7 @@ Proof. now rewrite <- opp_succ, opp_nonneg_nonpos, le_succ_l. Qed. -(** Accesing a high enough bit of a number gives its sign *) +(** Accessing a high enough bit of a number gives its sign *) Lemma bits_iff_nonneg : forall a n, log2 (abs a) < n -> (0<=a <-> a.[n] = false). diff --git a/theories/Numbers/Integer/Abstract/ZLcm.v b/theories/Numbers/Integer/Abstract/ZLcm.v index 0ab528de80..377c05e279 100644 --- a/theories/Numbers/Integer/Abstract/ZLcm.v +++ b/theories/Numbers/Integer/Abstract/ZLcm.v @@ -207,7 +207,7 @@ Qed. We had an abs in order to have an always-nonnegative lcm, in the spirit of gcd. Nota: [lcm 0 0] should be 0, which - isn't garantee with the third equation above. + isn't guarantee with the third equation above. *) Definition lcm a b := abs (a*(b/gcd a b)). diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v index 5f102e853b..b96a2b35af 100644 --- a/theories/Numbers/NatInt/NZAddOrder.v +++ b/theories/Numbers/NatInt/NZAddOrder.v @@ -149,7 +149,7 @@ Proof. intros n m H; apply add_le_cases; now nzsimpl. Qed. -(** Substraction *) +(** Subtraction *) (** We can prove the existence of a subtraction of any number by a smaller one *) diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v index acebfcf1d2..cace65c61d 100644 --- a/theories/Numbers/NatInt/NZDomain.v +++ b/theories/Numbers/NatInt/NZDomain.v @@ -310,7 +310,7 @@ Qed. End NZOfNatOrd. -(** For basic operations, we can prove correspondance with +(** For basic operations, we can prove correspondence with their counterpart in [nat]. *) Module NZOfNatOps (Import NZ:NZAxiomsSig'). diff --git a/theories/Numbers/Natural/Abstract/NLcm.v b/theories/Numbers/Natural/Abstract/NLcm.v index 47b74193ed..19a8b4b2b1 100644 --- a/theories/Numbers/Natural/Abstract/NLcm.v +++ b/theories/Numbers/Natural/Abstract/NLcm.v @@ -90,7 +90,7 @@ Qed. = (a / gcd a b) * b = (a*b) / gcd a b - Nota: [lcm 0 0] should be 0, which isn't garantee with the third + Nota: [lcm 0 0] should be 0, which isn't guarantee with the third equation above. *) diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index 7f30733559..1c78011941 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -310,7 +310,7 @@ Infix "<?" := ltb (at level 70, no associativity) : positive_scope. (** ** A Square Root function for positive numbers *) -(** We procede by blocks of two digits : if p is written qbb' +(** We proceed by blocks of two digits : if p is written qbb' then sqrt(p) will be sqrt(q)~0 or sqrt(q)~1. For deciding easily in which case we are, we store the remainder (as a mask, since it can be null). diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 5ae933d433..9fe3b967ae 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -31,7 +31,7 @@ Definition block {A : Type} (a : A) := a. Ltac block_goal := match goal with [ |- ?T ] => change (block T) end. Ltac unblock_goal := unfold block in *. -(** Notation for heterogenous equality. *) +(** Notation for heterogeneous equality. *) Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity). @@ -88,7 +88,7 @@ Ltac elim_eq_rect := end end. -(** Rewrite using uniqueness of indentity proofs [H = eq_refl]. *) +(** Rewrite using uniqueness of identity proofs [H = eq_refl]. *) Ltac simpl_uip := match goal with @@ -450,7 +450,7 @@ Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => destruct hyp using c) H. (** Then we have wrappers for usual calls to induction. One can customize the induction tactic by - writting another wrapper calling do_depelim. We suppose the hyp has to be generalized before + writing another wrapper calling do_depelim. We suppose the hyp has to be generalized before calling [induction]. *) Tactic Notation "dependent" "induction" ident(H) := diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index f18fca99a0..9eae960086 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -43,10 +43,10 @@ Proof. generalize (Z.gcd_nonneg a (Zpos b)) (Z.ggcd_correct_divisors a (Zpos b)). rewrite <- Z.ggcd_gcd. destruct Z.ggcd as (g,(aa,bb)); simpl in *. - injection H as <- <-. intros H (_,H'). + injection H as [= <- <-]. intros H (_,H'). destruct g as [|g|g]; [ discriminate | | now elim H ]. destruct bb as [|b|b]; simpl in *; try discriminate. - injection H' as H'. f_equal. + injection H' as [= H']. f_equal. apply Pos.mul_reg_r with b. now rewrite Pos.mul_1_l. Qed. @@ -87,7 +87,7 @@ Arguments Q2Qc q%Q. Lemma Q2Qc_eq_iff (q q' : Q) : Q2Qc q = Q2Qc q' <-> q == q'. Proof. split; intro H. - - now injection H as H%Qred_eq_iff. + - now injection H as [= H%Qred_eq_iff]. - apply Qc_is_canon. simpl. now rewrite H. Qed. @@ -269,7 +269,7 @@ Theorem Qcmult_integral : forall x y, x*y=0 -> x=0 \/ y=0. Proof. intros. destruct (Qmult_integral x y); try qc; auto. - injection H as H. + injection H as [= H]. rewrite <- (Qred_correct (x*y)). rewrite <- (Qred_correct 0). rewrite H; auto with qarith. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index ec283b886e..45cd74cf48 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -95,7 +95,7 @@ Proof. Qed. (*********************************************************) -(** ** Relating [<], [>], [<=] and [>=] *) +(** ** Relating [<], [>], [<=] and [>=] *) (*********************************************************) (*********************************************************) @@ -711,7 +711,7 @@ Proof. Qed. (*********************************************************) -(** ** Subtraction *) +(** ** Subtraction *) (*********************************************************) Lemma Rminus_0_r : forall r, r - 0 = r. @@ -1352,7 +1352,7 @@ Proof. Qed. (*********************************************************) -(** ** Order and substraction *) +(** ** Order and subtraction *) (*********************************************************) Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0. diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v index 08bc400f0a..142883a525 100644 --- a/theories/Sorting/PermutSetoid.v +++ b/theories/Sorting/PermutSetoid.v @@ -543,7 +543,7 @@ Qed. End Permut_permut. (* begin hide *) -(** For compatibilty *) +(** For compatibility *) Notation permut_right := permut_cons (only parsing). Notation permut_tran := permut_trans (only parsing). (* end hide *) diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index f5bc9eee4e..170c221a45 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -304,7 +304,7 @@ Qed. Lemma Permutation_length_1_inv: forall a l, Permutation [a] l -> l = [a]. Proof. intros a l H; remember [a] as m in H. - induction H; try (injection Heqm as -> ->); + induction H; try (injection Heqm as [= -> ->]); discriminate || auto. apply Permutation_nil in H as ->; trivial. Qed. @@ -312,7 +312,7 @@ Qed. Lemma Permutation_length_1: forall a b, Permutation [a] [b] -> a = b. Proof. intros a b H. - apply Permutation_length_1_inv in H; injection H as ->; trivial. + apply Permutation_length_1_inv in H; injection H as [= ->]; trivial. Qed. Lemma Permutation_length_2_inv : @@ -320,7 +320,7 @@ Lemma Permutation_length_2_inv : Proof. intros a1 a2 l H; remember [a1;a2] as m in H. revert a1 a2 Heqm. - induction H; intros; try (injection Heqm as ? ?; subst); + induction H; intros; try (injection Heqm as [= ? ?]; subst); discriminate || (try tauto). apply Permutation_length_1_inv in H as ->; left; auto. apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as []; @@ -332,7 +332,7 @@ Lemma Permutation_length_2 : a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. Proof. intros a1 b1 a2 b2 H. - apply Permutation_length_2_inv in H as [H|H]; injection H as -> ->; auto. + apply Permutation_length_2_inv in H as [H|H]; injection H as [= -> ->]; auto. Qed. Lemma NoDup_Permutation l l' : NoDup l -> NoDup l' -> diff --git a/theories/Strings/String.v b/theories/Strings/String.v index 08ccfac877..85bde6a4df 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -123,7 +123,7 @@ intros H; generalize (H O); simpl; intros H1; inversion H1. case (Rec s). intros H0; rewrite H0; auto. intros n; exact (H (S n)). -intros H; injection H as H1 H2. +intros [= H1 H2]. rewrite H2; trivial. rewrite H1; auto. Qed. @@ -290,14 +290,14 @@ intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; auto. intros n; case n; simpl; auto. intros m s1; case s1; simpl; auto. -intros H; injection H as <-; auto. +intros [= <-]; auto. intros; discriminate. intros; discriminate. intros b s2' Rec n m s1. case n; simpl; auto. generalize (prefix_correct s1 (String b s2')); case (prefix s1 (String b s2')). -intros H0 H; injection H as <-; auto. +intros H0 [= <-]; auto. case H0; simpl; auto. case m; simpl; auto. case (index O s1 s2'); intros; discriminate. @@ -323,7 +323,7 @@ intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl; auto. intros n; case n; simpl; auto. intros m s1; case s1; simpl; auto. -intros H; injection H as <-. +intros [= <-]. intros p H0 H2; inversion H2. intros; discriminate. intros; discriminate. @@ -331,7 +331,7 @@ intros b s2' Rec n m s1. case n; simpl; auto. generalize (prefix_correct s1 (String b s2')); case (prefix s1 (String b s2')). -intros H0 H; injection H as <-; auto. +intros H0 [= <-]; auto. intros p H2 H3; inversion H3. case m; simpl; auto. case (index 0 s1 s2'); intros; discriminate. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index d000b75bf4..e5b2e22dc1 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -208,7 +208,7 @@ Module OrderedTypeFacts (Import O: OrderedType). unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto. Qed. -(* Specialization of resuts about lists modulo. *) +(* Specialization of results about lists modulo. *) Section ForNotations. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 182b781fe1..354c1eb9b0 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -431,7 +431,7 @@ Proof. apply eq_true_iff_eq. now rewrite negb_true_iff, ltb_lt, leb_gt. Qed. -(** Relation bewteen [compare] and the boolean comparisons *) +(** Relation between [compare] and the boolean comparisons *) Lemma eqb_compare x y : (x =? y) = match compare x y with Eq => true | _ => false end. diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v index ebd8ee8fc2..80925ff058 100644 --- a/theories/Structures/OrdersTac.v +++ b/theories/Structures/OrdersTac.v @@ -51,7 +51,7 @@ Local Infix "+" := trans_ord. This used to be provided here via a [TotalOrder], but for technical reasons related to extraction, we now ask - for two sperate parts: relations in a [EqLtLe] + properties in + for two separate parts: relations in a [EqLtLe] + properties in [IsTotalOrder]. Note that [TotalOrder = EqLtLe <+ IsTotalOrder] *) diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v index 4088843a1b..0b3e9b78f6 100644 --- a/theories/Vectors/Fin.v +++ b/theories/Vectors/Fin.v @@ -160,7 +160,7 @@ Qed. (** The p{^ th} element of [fin m] viewed as the p{^ th} element of [fin (n + m)] -Really really ineficient !!! *) +Really really inefficient !!! *) Definition L_R {m} n (p : t m) : t (n + m). Proof. induction n. diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index b2d08186ea..60db536dce 100644 --- a/theories/Wellfounded/Lexicographic_Product.v +++ b/theories/Wellfounded/Lexicographic_Product.v @@ -46,11 +46,11 @@ Section WfLexicographic_Product. apply H2. auto with sets. - + injection H1 as <- _. - injection H3 as <- _; auto with sets. + + injection H1 as [= <- _]. + injection H3 as [= <- _]; auto with sets. - rewrite <- H1. - injection H3 as -> H3. + injection H3 as [= -> H3]. apply IHAcc0. elim inj_pair2 with A B x y' x0; assumption. Defined. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index a346ab8ccb..43841920e5 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1259,7 +1259,7 @@ Proof. f_equal. now rewrite <- add_assoc, add_opp_diag_r, add_0_r. Qed. -(** * [testbit] in terms of comparision. *) +(** * [testbit] in terms of comparison. *) Lemma testbit_mod_pow2 a n i (H : 0 <= n) : testbit (a mod 2 ^ n) i = ((i <? n) && testbit a i)%bool. diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v index 8cb62622db..a9a5f15f2e 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -28,7 +28,7 @@ Module Z. Definition t := Z. -(** ** Nicer names [Z.pos] and [Z.neg] for contructors *) +(** ** Nicer names [Z.pos] and [Z.neg] for constructors *) Notation pos := Zpos. Notation neg := Zneg. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 0b0ed48d51..9cade75f08 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -13,7 +13,7 @@ (** We define a signature for an integer datatype based on [Z]. The goal is to allow a switch after extraction to ocaml's [big_int] or even [int] when finiteness isn't a problem - (typically : when mesuring the height of an AVL tree). + (typically : when measuring the height of an AVL tree). *) Require Import BinInt. diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v index a619eb90ef..64431a9411 100644 --- a/theories/ZArith/Zquot.v +++ b/theories/ZArith/Zquot.v @@ -105,7 +105,7 @@ Proof. rewrite Z.rem_sign_nz; trivial. apply Z.square_nonneg. Qed. -(** This can also be said in a simplier way: *) +(** This can also be said in a simpler way: *) Theorem Zrem_sgn2 a b : 0 <= (Z.rem a b) * a. Proof. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 2ec55d1bd0..d37d2bea94 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -171,7 +171,7 @@ DYNOBJ:=.cmxs DYNLIB:=.cmxs endif -# these variables are meant to be overriden if you want to add *extra* flags +# these variables are meant to be overridden if you want to add *extra* flags COQEXTRAFLAGS?= COQCHKEXTRAFLAGS?= COQDOCEXTRAFLAGS?= diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 8823206252..c00fb71dba 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -454,7 +454,7 @@ let usage () = eprintf " -I dir : add (non recursively) dir to ocaml path\n"; eprintf " -R dir -as logname : add and import dir recursively to coq load path under logical name logname\n"; (* deprecate? *) eprintf " -R dir logname : add and import dir recursively to coq load path under logical name logname\n"; - eprintf " -Q dir logname : add (recusively) and open (non recursively) dir to coq load path under logical name logname\n"; + eprintf " -Q dir logname : add (recursively) and open (non recursively) dir to coq load path under logical name logname\n"; eprintf " -dumpgraph f : print a dot dependency graph in file 'f'\n"; eprintf " -dumpgraphbox f : print a dot dependency graph box in file 'f'\n"; eprintf " -exclude-dir dir : skip subdirectories named 'dir' during -R/-Q search\n"; diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index b703af934d..75667ae909 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -762,7 +762,7 @@ module Html = struct (* inference rules *) let inf_rule assumptions (_,_,midnm) conclusions = - (* this first function replaces any occurance of 3 or more spaces + (* this first function replaces any occurrence of 3 or more spaces in a row with " "s. We do this to the assumptions so that people can put multiple rules on a line with nice formatting *) let replace_spaces str = diff --git a/tools/coqdoc/tokens.mli b/tools/coqdoc/tokens.mli index 00db2ad317..6449cd5b6f 100644 --- a/tools/coqdoc/tokens.mli +++ b/tools/coqdoc/tokens.mli @@ -57,7 +57,7 @@ val translate : string -> string option dictionary, "<>_h" is one word and gets translated *) -(* Warning: do not output anything on output channel inbetween a call +(* Warning: do not output anything on output channel in between a call to [output_tagged_*] and [flush_sublexer]!! *) type out_function = diff --git a/tools/coqwc.mll b/tools/coqwc.mll index f0f138740c..06b4ad5fd3 100644 --- a/tools/coqwc.mll +++ b/tools/coqwc.mll @@ -207,7 +207,7 @@ and string = parse | eof { 0 } (*s The following entry [read_header] is used to skip the possible header at - the beggining of files (unless option \texttt{-e} is specified). + the beginning of files (unless option \texttt{-e} is specified). It stops whenever it encounters an empty line or any character outside a comment. In this last case, it correctly resets the lexer position on that character (decreasing [lex_curr_pos] by 1). *) diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 2f63410761..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 = @@ -225,7 +225,7 @@ let do_vio opts copts = process happens outside of the STM *) if copts.vio_files <> [] || copts.vio_tasks <> [] then let iload_path = build_load_path opts in - List.iter Mltop.add_coq_path iload_path; + List.iter Loadpath.add_coq_path iload_path; (* Vio compile pass *) if copts.vio_files <> [] then schedule_vio copts; diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index ec43dbb1d7..4ef31c73b7 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -46,8 +46,8 @@ type t = { load_rcfile : bool; rcfile : string option; - ml_includes : Mltop.coq_path list; - vo_includes : Mltop.coq_path list; + ml_includes : Loadpath.coq_path list; + vo_includes : Loadpath.coq_path list; vo_requires : (string * string option * bool option) list; (* None = No Import; Some false = Import; Some true = Export *) @@ -147,10 +147,10 @@ let default = { (* Functional arguments *) (******************************************************************************) let add_ml_include opts s = - Mltop.{ opts with ml_includes = {recursive = false; path_spec = MlPath s} :: opts.ml_includes } + Loadpath.{ opts with ml_includes = {recursive = false; path_spec = MlPath s} :: opts.ml_includes } let add_vo_include opts unix_path coq_path implicit = - let open Mltop in + let open Loadpath in let coq_path = Libnames.dirpath_of_string coq_path in { opts with vo_includes = { recursive = true; @@ -273,7 +273,7 @@ let usage help = end; let lp = Coqinit.toplevel_init_load_path () in (* Necessary for finding the toplevels below *) - List.iter Mltop.add_coq_path lp; + List.iter Loadpath.add_coq_path lp; help () (* Main parsing routine *) diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index d7f9819bee..015789c1f3 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -22,8 +22,8 @@ type t = { load_rcfile : bool; rcfile : string option; - ml_includes : Mltop.coq_path list; - vo_includes : Mltop.coq_path list; + ml_includes : Loadpath.coq_path list; + vo_includes : Loadpath.coq_path list; vo_requires : (string * string option * bool option) list; toplevel_name : Stm.interactive_top; @@ -69,4 +69,4 @@ val parse_args : help:(unit -> unit) -> init:t -> string list -> t * string list val exitcode : t -> int val require_libs : t -> (string * string option * bool option) list -val build_load_path : t -> Mltop.coq_path list +val build_load_path : t -> Loadpath.coq_path list diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index 2279ce5505..63c37e2251 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -63,7 +63,10 @@ let check_compilation_output_name_consistency args = prerr_endline ("file have to be compiled") | _ -> () +let is_dash_argument s = String.length s > 0 && s.[0] = '-' + let add_compile ?echo copts s = + if is_dash_argument s then (prerr_endline ("Unknown option " ^ s); exit 1); (* make the file name explicit; needed not to break up Coq loadpath stuff. *) let echo = Option.default copts.echo echo in let s = diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 74a089510e..f4ae00ed65 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -17,7 +17,7 @@ let set_debug () = let () = Backtrace.record_backtrace true in Flags.debug := true -(* Loading of the ressource file. +(* Loading of the resource file. rcfile is either $XDG_CONFIG_HOME/.coqrc.VERSION, or $XDG_CONFIG_HOME/.coqrc if the first one does not exist. *) @@ -53,25 +53,25 @@ let load_rcfile ~rcfile ~state = (* Recursively puts dir in the LoadPath if -nois was not passed *) let build_stdlib_path ~load_init ~unix_path ~coq_path ~with_ml = - let open Mltop in + let open Loadpath in let add_ml = if with_ml then AddRecML else AddNoML in { recursive = true; path_spec = VoPath { unix_path; coq_path ; has_ml = add_ml; implicit = load_init } } let build_userlib_path ~unix_path = - let open Mltop in + let open Loadpath in { recursive = true; path_spec = VoPath { unix_path; coq_path = Libnames.default_root_prefix; - has_ml = Mltop.AddRecML; + has_ml = AddRecML; implicit = false; } } let ml_path_if c p = - let open Mltop in + let open Loadpath in let f x = { recursive = false; path_spec = MlPath x } in if c then List.map f p else [] @@ -85,7 +85,7 @@ let toplevel_init_load_path () = (* LoadPath for Coq user libraries *) let libs_init_load_path ~load_init = - let open Mltop in + let open Loadpath in let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x)) in @@ -115,10 +115,10 @@ let libs_init_load_path ~load_init = (* Initialises the Ocaml toplevel before launching it, so that it can find the "include" file in the *source* directory *) let init_ocaml_path () = - let open Mltop in + let open Loadpath in let lp s = { recursive = false; path_spec = MlPath s } in let add_subdir dl = - Mltop.add_coq_path (lp (List.fold_left (/) Envars.coqroot [dl])) + Loadpath.add_coq_path (lp (List.fold_left (/) Envars.coqroot [dl])) in - Mltop.add_coq_path (lp (Envars.coqlib ())); + Loadpath.add_coq_path (lp (Envars.coqlib ())); List.iter add_subdir Coq_config.all_src_dirs diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index c891e736b4..04ec77a025 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -17,7 +17,7 @@ val load_rcfile : rcfile:(string option) -> state:Vernac.State.t -> Vernac.State val init_ocaml_path : unit -> unit (* LoadPath for toploop toplevels *) -val toplevel_init_load_path : unit -> Mltop.coq_path list +val toplevel_init_load_path : unit -> Loadpath.coq_path list (* LoadPath for Coq user libraries *) -val libs_init_load_path : load_init:bool -> Mltop.coq_path list +val libs_init_load_path : load_init:bool -> Loadpath.coq_path list diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 0cc22ba31d..852a65f07b 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -17,7 +17,7 @@ type input_buffer = { mutable prompt : Stm.doc -> string; mutable str : Bytes.t; (** buffer of already read characters *) mutable len : int; (** number of chars in the buffer *) - mutable bols : int list; (** offsets in str of begining of lines *) + mutable bols : int list; (** offsets in str of beginning of lines *) mutable tokens : Pcoq.Parsable.t; (** stream of tokens *) mutable start : int } (** stream count of the first char of the buffer *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index b769405cf6..460c2f126e 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -222,7 +222,7 @@ let init_toplevel ~help ~init custom_init arglist = exit 0; end; let top_lp = Coqinit.toplevel_init_load_path () in - List.iter Mltop.add_coq_path top_lp; + List.iter Loadpath.add_coq_path top_lp; let opts, extras = custom_init ~opts extras in Mltop.init_known_plugins (); diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index c41f16c95b..41bff34bd3 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -37,7 +37,7 @@ let vernac_echo ?loc in_chan = let open Loc in Feedback.msg_notice @@ str @@ really_input_string in_chan len ) loc -(* Reenable when we get back to feedback printing *) +(* Re-enable when we get back to feedback printing *) (* let is_end_of_input any = match any with *) (* Stm.End_of_input -> true *) (* | _ -> false *) diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index 1701bf4365..40946a8d56 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -48,7 +48,7 @@ Ltac2 @ external make : kind -> constr := "ltac2" "constr_make". Ltac2 @ external check : constr -> constr result := "ltac2" "constr_check". (** Checks that a constr generated by unsafe means is indeed safe in the current environment, and returns it, or the error otherwise. Panics if - not focussed. *) + not focused. *) Ltac2 @ external substnl : constr list -> int -> constr -> constr := "ltac2" "constr_substnl". (** [substnl [r₁;...;rₙ] k c] substitutes in parallel [Rel(k+1); ...; Rel(k+n)] with @@ -68,6 +68,6 @@ Ltac2 @ external constructor : inductive -> int -> constructor := "ltac2" "const End Unsafe. Ltac2 @ external in_context : ident -> constr -> (unit -> unit) -> constr := "ltac2" "constr_in_context". -(** On a focussed goal [Γ ⊢ A], [in_context id c tac] evaluates [tac] in a - focussed goal [Γ, id : c ⊢ ?X] and returns [fun (id : c) => t] where [t] is +(** On a focused goal [Γ ⊢ A], [in_context id c tac] evaluates [tac] in a + focused goal [Γ, id : c ⊢ ?X] and returns [fun (id : c) => t] where [t] is the proof built by the tactic. *) diff --git a/user-contrib/Ltac2/Pattern.v b/user-contrib/Ltac2/Pattern.v index 8d1fb0cd8a..5e8eef526e 100644 --- a/user-contrib/Ltac2/Pattern.v +++ b/user-contrib/Ltac2/Pattern.v @@ -25,7 +25,7 @@ Ltac2 @ external empty_context : unit -> context := Ltac2 @ external matches : t -> constr -> (ident * constr) list := "ltac2" "pattern_matches". (** If the term matches the pattern, returns the bound variables. If it doesn't, - fail with [Match_failure]. Panics if not focussed. *) + fail with [Match_failure]. Panics if not focused. *) Ltac2 @ external matches_subterm : t -> constr -> context * ((ident * constr) list) := "ltac2" "pattern_matches_subterm". 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/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 1069d0bfa3..af7bc32785 100644 --- a/user-contrib/Ltac2/tac2expr.mli +++ b/user-contrib/Ltac2/tac2expr.mli @@ -168,12 +168,10 @@ 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} *) -(** Values are represented in a way similar to OCaml, i.e. they constrast +(** Values are represented in a way similar to OCaml, i.e. they contrast immediate integers (integers, constructors without arguments) and structured blocks (tuples, arrays, constructors with arguments), as well as a few other base cases, namely closures, strings, named constructors, and dynamic type diff --git a/user-contrib/Ltac2/tac2intern.mli b/user-contrib/Ltac2/tac2intern.mli index d646b5cda5..829570a354 100644 --- a/user-contrib/Ltac2/tac2intern.mli +++ b/user-contrib/Ltac2/tac2intern.mli @@ -20,7 +20,7 @@ val is_value : glb_tacexpr -> bool val check_unit : ?loc:Loc.t -> type_scheme -> unit val check_subtype : type_scheme -> type_scheme -> bool -(** [check_subtype t1 t2] returns [true] iff all values of intances of type [t1] +(** [check_subtype t1 t2] returns [true] iff all values of instances of type [t1] also have type [t2]. *) val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr diff --git a/user-contrib/Ltac2/tac2match.ml b/user-contrib/Ltac2/tac2match.ml index 058d02adde..354a578cb3 100644 --- a/user-contrib/Ltac2/tac2match.ml +++ b/user-contrib/Ltac2/tac2match.ml @@ -88,7 +88,7 @@ module PatternMatching (E:StaticEnvironment) = struct (** To focus on the algorithmic portion of pattern-matching, the bookkeeping is relegated to a monad: the composition of the - bactracking monad of {!IStream.t} with a "writer" effect. *) + backtracking monad of {!IStream.t} with a "writer" effect. *) (* spiwack: as we don't benefit from the various stream optimisations of Haskell, it may be costly to give the monad in direct style such as here. We may want to use some continuation passing style. *) diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 445f10ecc1..9353ef3902 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -168,7 +168,7 @@ let rec traverse current ctx accu t = match Constr.kind t with let body () = id |> Global.lookup_named |> NamedDecl.get_value in traverse_object accu body (VarRef id) | Const (kn, _) -> - let body () = Option.map fst (Global.body_of_constant_body (lookup_constant kn)) in + let body () = Option.map fst (Global.body_of_constant_body Library.indirect_accessor (lookup_constant kn)) in traverse_object accu body (ConstRef kn) | Ind ((mind, _) as ind, _) -> traverse_inductive accu mind (IndRef ind) @@ -181,7 +181,7 @@ let rec traverse current ctx accu t = match Constr.kind t with | Lambda(_,_,oty), Const (kn, _) when Vars.noccurn 1 oty && not (Declareops.constant_has_body (lookup_constant kn)) -> - let body () = Option.map fst (Global.body_of_constant_body (lookup_constant kn)) in + let body () = Option.map fst (Global.body_of_constant_body Library.indirect_accessor (lookup_constant kn)) in traverse_object ~inhabits:(current,ctx,Vars.subst1 mkProp oty) accu body (ConstRef kn) | _ -> diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 528829f3a5..5aec5cac2c 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -331,8 +331,8 @@ let build_beq_scheme mode kn = eff := Safe_typing.concat_private eff' !eff done; (Array.init nb_ind (fun i -> - let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in - if not (Sorts.List.mem InSet kelim) then + let kelim = Inductive.elim_sort (mib,mib.mind_packets.(i)) in + if not (Sorts.family_leq InSet kelim) then raise (NonSingletonProp (kn,i)); let fix = match mib.mind_finite with | CoFinite -> diff --git a/vernac/classes.ml b/vernac/classes.ml index 5a7f60584a..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,31 +426,111 @@ 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 bk cl = - let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in - let tclass, ids = - match bk with - | Decl_kinds.Implicit -> - Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false - (fun avoid (clname, _) -> - match clname with - | Some cl -> - let t = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) in - t, avoid - | None -> failwith ("new instance: under-applied typeclass")) - cl - | Explicit -> cl, Id.Set.empty + 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) else tclass @@ -535,15 +557,12 @@ let interp_instance_context ~program_mode env ctx ?(generalize=false) pl bk cl = 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 ctx (instid, bk, 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 bk cl + 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 @@ -552,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 ctx (instid, bk, cl) pri = +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 bk 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 57bb9ce312..e61935c87a 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -31,43 +31,51 @@ 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 -> - Decl_kinds.polymorphic -> - local_binder_expr list -> - Vernacexpr.typeclass_constraint -> - (bool * constr_expr) option -> - ?generalize:bool -> - ?tac:unit Proofview.tactic -> - ?hook:(GlobRef.t -> unit) -> - Hints.hint_info_expr -> - (* May open a proof *) - Id.t * Proof_global.t option - -val declare_new_instance : - ?global:bool (** Not global by default. *) -> - program_mode:bool -> - Decl_kinds.polymorphic -> - local_binder_expr list -> - ident_decl * Decl_kinds.binding_kind * constr_expr -> - Hints.hint_info_expr -> - unit + ?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 + -> ?hook:(GlobRef.t -> unit) + -> Hints.hint_info_expr + -> Id.t + +val declare_new_instance + : ?global:bool (** Not global by default. *) + -> program_mode:bool + -> Decl_kinds.polymorphic + -> ident_decl + -> local_binder_expr list + -> constr_expr + -> Hints.hint_info_expr + -> unit (** {6 Low level interface used by Add Morphism, do not use } *) val mk_instance : typeclass -> hint_info -> bool -> GlobRef.t -> instance diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 635751bb24..c37e90650a 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -146,7 +146,7 @@ let do_assumptions ~program_mode kind nl l = l [] else l in - (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) + (* We interpret all declarations in the same evar_map, i.e. as a telescope. *) let (sigma,_,_),l = List.fold_left_map (fun (sigma,env,ienv) (is_coe,(idl,c)) -> let sigma,(t,imps) = interp_assumption ~program_mode sigma env ienv c in let r = Retyping.relevance_of_type env sigma t in diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 00f19f545c..7a4e6d8698 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -255,85 +255,84 @@ 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 | CMeasureRec (None,_,_) when not structonly -> - user_err Pp.(str "Decreasing argument must be specificed in measure clause.") + user_err Pp.(str "Decreasing argument must be specified in measure clause.") | _ -> user_err Pp.(str "Well-founded induction requires Program Fixpoint or Function.") @@ -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/egramcoq.ml b/vernac/egramcoq.ml index 568e5b9997..9bc225475d 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -546,6 +546,15 @@ let extend_constr state forpat ng = let constr_levels = GramState.field () +let is_disjunctive_pattern_rule ng = + String.is_sub "( _ | " (snd ng.notgram_notation) 0 + +let warn_disj_pattern_notation = + let open Pp in + let pp ng = str "Use of " ++ Notation.pr_notation ng.notgram_notation ++ + str " Notation is deprecated as it is inconsistent with pattern syntax." in + CWarnings.create ~name:"disj-pattern-notation" ~category:"notation" ~default:CWarnings.Disabled pp + let extend_constr_notation ng state = let levels = match GramState.get state constr_levels with | None -> String.Map.add "constr" default_constr_levels String.Map.empty @@ -553,8 +562,13 @@ let extend_constr_notation ng state = in (* Add the notation in constr *) let (r, levels) = extend_constr levels ForConstr ng in - (* Add the notation in cases_pattern *) - let (r', levels) = extend_constr levels ForPattern ng in + (* Add the notation in cases_pattern, unless it would disrupt *) + (* parsing nested disjunctive patterns. *) + let (r', levels) = + if is_disjunctive_pattern_rule ng then begin + warn_disj_pattern_notation ng; + ([], levels) + end else extend_constr levels ForPattern ng in let state = GramState.set state constr_levels levels in (r @ r', state) 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 6438b48e32..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,14 +295,14 @@ 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 } ]; cs = [ "|"; l' = LIST0 univ_constraint SEP ","; ext = [ "+" -> { true } | -> { false } ]; "}" -> { (l',ext) } - | ext = [ "}" -> { true } | "|}" -> { false } ] -> { ([], ext) } ] + | ext = [ "}" -> { true } | bar_cbrace -> { false } ] -> { ([], ext) } ] -> { let open UState in { univdecl_instance = l; @@ -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 *) @@ -723,11 +722,11 @@ GRAMMAR EXTEND Gram { VernacContext (List.flatten c) } | IDENT "Instance"; namesup = instance_name; ":"; - expl = [ "!" -> { Decl_kinds.Implicit } | -> { Decl_kinds.Explicit } ] ; t = operconstr LEVEL "200"; + t = operconstr LEVEL "200"; info = hint_info ; props = [ ":="; "{"; r = record_declaration; "}" -> { Some (true,r) } | ":="; c = lconstr -> { Some (false,c) } | -> { None } ] -> - { VernacInstance (snd namesup,(fst namesup,expl,t),props,info) } + { VernacInstance (fst namesup,snd namesup,t,props,info) } | IDENT "Existing"; IDENT "Instance"; id = global; info = hint_info -> @@ -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 @@ -888,9 +895,9 @@ GRAMMAR EXTEND Gram (* Hack! Should be in grammar_ext, but camlp5 factorizes badly *) | IDENT "Declare"; IDENT "Instance"; id = ident_decl; bl = binders; ":"; - expl = [ "!" -> { Decl_kinds.Implicit } | -> { Decl_kinds.Explicit } ] ; t = operconstr LEVEL "200"; + t = operconstr LEVEL "200"; info = hint_info -> - { VernacDeclareInstance (bl, (id, expl, t), info) } + { VernacDeclareInstance (id, bl, t, info) } (* Should be in syntax, but camlp5 would not factorize *) | IDENT "Declare"; IDENT "Scope"; sc = IDENT -> diff --git a/vernac/himsg.ml b/vernac/himsg.ml index b2382ce6fc..a1f7835cbe 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -219,6 +219,7 @@ let explain_elim_arity env sigma ind c pj okinds = let pc = pr_leconstr_env env sigma c in let msg = match okinds with | Some(sorts,kp,ki,explanation) -> + let sorts = Inductiveops.sorts_below sorts in let pki = Sorts.pr_sort_family ki in let pkp = Sorts.pr_sort_family kp in let explanation = match explanation with diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 642695bda4..de7d2fd49a 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -216,11 +216,11 @@ let declare_one_case_analysis_scheme ind = else if not (Inductiveops.has_dependent_elim mib) then case_scheme_kind_from_type else case_dep_scheme_kind_from_type in - let kelim = elim_sorts (mib,mip) in + let kelim = elim_sort (mib,mip) in (* in case the inductive has a type elimination, generates only one induction scheme, the other ones share the same code with the - apropriate type *) - if Sorts.List.mem InType kelim then + appropriate type *) + if Sorts.family_leq InType kelim then ignore (define_individual_scheme dep UserAutomaticRequest None ind) (* Induction/recursion schemes *) @@ -248,16 +248,17 @@ let declare_one_induction_scheme ind = let kind = inductive_sort_family mip in let from_prop = kind == InProp in let depelim = Inductiveops.has_dependent_elim mib in - let kelim = elim_sorts (mib,mip) in + let kelim = Inductiveops.sorts_below (elim_sort (mib,mip)) in let kelim = if Global.sprop_allowed () then kelim else List.filter (fun s -> s <> InSProp) kelim in let elims = List.map_filter (fun (sort,kind) -> - if Sorts.List.mem sort kelim then Some kind else None) + if List.mem_f Sorts.family_equal sort kelim then Some kind else None) (if from_prop then kinds_from_prop else if depelim then kinds_from_type - else nondep_kinds_from_type) in + else nondep_kinds_from_type) + in List.iter (fun kind -> ignore (define_individual_scheme kind UserAutomaticRequest None ind)) elims diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 317cf487cc..d14c7ddf8f 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -57,7 +57,7 @@ let retrieve_first_recthm uctx = function let uctx = UState.context uctx in let inst = Univ.UContext.instance uctx in let map (c, ctx) = Vars.subst_instance_constr inst c in - (Option.map map (Global.body_of_constant_body cb), is_opaque cb) + (Option.map map (Global.body_of_constant_body Library.indirect_accessor cb), is_opaque cb) | _ -> assert false let adjust_guardness_conditions const = function @@ -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/loadpath.ml b/vernac/loadpath.ml new file mode 100644 index 0000000000..f5e8b6d12f --- /dev/null +++ b/vernac/loadpath.ml @@ -0,0 +1,273 @@ +(************************************************************************) +(* * 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 +module DP = Names.DirPath + +(** Load paths. Mapping from physical to logical paths. *) + +type t = { + path_physical : CUnix.physical_path; + path_logical : DP.t; + path_implicit : bool; +} + +let load_paths = Summary.ref ([] : t list) ~name:"LOADPATHS" + +let logical p = p.path_logical +let physical p = p.path_physical + +let pp p = + let dir = DP.print p.path_logical in + let path = Pp.str (CUnix.escaped_string_of_physical_path p.path_physical) in + Pp.(hov 2 (dir ++ spc () ++ path)) + +let get_load_paths () = !load_paths + +let anomaly_too_many_paths path = + CErrors.anomaly Pp.(str "Several logical paths are associated to" ++ spc () ++ str path ++ str ".") + +let find_load_path phys_dir = + let phys_dir = CUnix.canonical_path_name phys_dir in + let filter p = String.equal p.path_physical phys_dir in + let paths = List.filter filter !load_paths in + match paths with + | [] -> raise Not_found + | [p] -> p + | _ -> anomaly_too_many_paths phys_dir + +let remove_load_path dir = + let filter p = not (String.equal p.path_physical dir) in + load_paths := List.filter filter !load_paths + +let warn_overriding_logical_loadpath = + CWarnings.create ~name:"overriding-logical-loadpath" ~category:"loadpath" + (fun (phys_path, old_path, coq_path) -> + Pp.(seq [str phys_path; strbrk " was previously bound to " + ; DP.print old_path; strbrk "; it is remapped to " + ; DP.print coq_path])) + +let add_load_path phys_path coq_path ~implicit = + let phys_path = CUnix.canonical_path_name phys_path in + let filter p = String.equal p.path_physical phys_path in + let binding = { + path_logical = coq_path; + path_physical = phys_path; + path_implicit = implicit; + } in + match List.filter filter !load_paths with + | [] -> + load_paths := binding :: !load_paths + | [{ path_logical = old_path; path_implicit = old_implicit }] -> + let replace = + if DP.equal coq_path old_path then + implicit <> old_implicit + else + let () = + (* Do not warn when overriding the default "-I ." path *) + if not (DP.equal old_path Libnames.default_root_prefix) then + warn_overriding_logical_loadpath (phys_path, old_path, coq_path) + in + true in + if replace then + begin + remove_load_path phys_path; + load_paths := binding :: !load_paths; + end + | _ -> anomaly_too_many_paths phys_path + +let filter_path f = + let rec aux = function + | [] -> [] + | p :: l -> + if f p.path_logical then (p.path_physical, p.path_logical) :: aux l + else aux l + in + aux !load_paths + +let expand_path ?root dir = + let rec aux = function + | [] -> [] + | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l -> + let success = + match root with + | None -> + if implicit then Libnames.is_dirpath_suffix_of dir lg + else DP.equal dir lg + | Some root -> + Libnames.(is_dirpath_prefix_of root lg && + is_dirpath_suffix_of dir (drop_dirpath_prefix root lg)) in + if success then (ph, lg) :: aux l else aux l in + aux !load_paths + +let locate_file fname = + let paths = List.map physical !load_paths in + let _,longfname = + System.find_file_in_path ~warn:(not !Flags.quiet) paths fname in + longfname + +(************************************************************************) +(*s Locate absolute or partially qualified library names in the path *) + +type library_location = LibLoaded | LibInPath +type locate_error = LibUnmappedDir | LibNotFound +type 'a locate_result = ('a, locate_error) result + +let warn_several_object_files = + CWarnings.create ~name:"several-object-files" ~category:"require" + Pp.(fun (vi, vo) -> + seq [ str "Loading"; spc (); str vi + ; strbrk " instead of "; str vo + ; strbrk " because it is more recent" + ]) + + +let select_vo_file ~warn loadpath base = + let find ext = + let loadpath = List.map fst loadpath in + try + let name = Names.Id.to_string base ^ ext in + let lpath, file = + System.where_in_path ~warn loadpath name in + Some (lpath, file) + with Not_found -> None in + match find ".vo", find ".vio" with + | None, None -> + Error LibNotFound + | Some res, None | None, Some res -> + Ok res + | Some (_, vo), Some (_, vi as resvi) + when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> + warn_several_object_files (vi, vo); + Ok resvi + | Some resvo, Some _ -> + Ok resvo + +let locate_absolute_library dir : CUnix.physical_path locate_result = + (* Search in loadpath *) + let pref, base = Libnames.split_dirpath dir in + let loadpath = filter_path (fun dir -> DP.equal dir pref) in + match loadpath with + | [] -> Error LibUnmappedDir + | _ -> + match select_vo_file ~warn:false loadpath base with + | Ok (_, file) -> Ok file + | Error fail -> Error fail + +let locate_qualified_library ?root ?(warn = true) qid : + (library_location * DP.t * CUnix.physical_path) locate_result = + (* Search library in loadpath *) + let dir, base = Libnames.repr_qualid qid in + let loadpath = expand_path ?root dir in + match loadpath with + | [] -> Error LibUnmappedDir + | _ -> + match select_vo_file ~warn loadpath base with + | Ok (lpath, file) -> + let dir = Libnames.add_dirpath_suffix + (CString.List.assoc lpath loadpath) base in + (* Look if loaded *) + if Library.library_is_loaded dir + then Ok (LibLoaded, dir, Library.library_full_filename dir) + (* Otherwise, look for it in the file system *) + else Ok (LibInPath, dir, file) + | Error fail -> Error fail + +let error_unmapped_dir qid = + let prefix, _ = Libnames.repr_qualid qid in + CErrors.user_err ~hdr:"load_absolute_library_from" + Pp.(seq [ str "Cannot load "; Libnames.pr_qualid qid; str ":"; spc () + ; str "no physical path bound to"; spc () + ; DP.print prefix; fnl () + ]) + +let error_lib_not_found qid = + CErrors.user_err ~hdr:"load_absolute_library_from" + Pp.(seq [ str "Cannot find library "; Libnames.pr_qualid qid; str" in loadpath"]) + +let try_locate_absolute_library dir = + match locate_absolute_library dir with + | Ok res -> res + | Error LibUnmappedDir -> + error_unmapped_dir (Libnames.qualid_of_dirpath dir) + | Error LibNotFound -> + error_lib_not_found (Libnames.qualid_of_dirpath dir) + +(** { 5 Extending the load path } *) + +(* Adds a path to the Coq and ML paths *) +type add_ml = AddNoML | AddTopML | AddRecML + +type vo_path_spec = { + unix_path : string; (* Filesystem path containing vo/ml files *) + coq_path : DP.t; (* Coq prefix for the path *) + implicit : bool; (* [implicit = true] avoids having to qualify with [coq_path] *) + has_ml : add_ml; (* If [has_ml] is true, the directory will also be search for plugins *) +} + +type coq_path_spec = + | VoPath of vo_path_spec + | MlPath of string + +type coq_path = { + path_spec: coq_path_spec; + recursive: bool; +} + +let warn_cannot_open_path = + CWarnings.create ~name:"cannot-open-path" ~category:"filesystem" + (fun unix_path -> Pp.(str "Cannot open " ++ str unix_path)) + +let warn_cannot_use_directory = + CWarnings.create ~name:"cannot-use-directory" ~category:"filesystem" + (fun d -> + Pp.(str "Directory " ++ str d ++ + strbrk " cannot be used as a Coq identifier (skipped)")) + +let convert_string d = + try Names.Id.of_string d + with + | CErrors.UserError _ -> + let d = Unicode.escaped_if_non_utf8 d in + warn_cannot_use_directory d; + raise Exit + +let add_vo_path ~recursive lp = + let unix_path = lp.unix_path in + let implicit = lp.implicit in + if System.exists_dir unix_path then + let dirs = if recursive then System.all_subdirs ~unix_path else [] in + let prefix = DP.repr lp.coq_path in + let convert_dirs (lp, cp) = + try + let path = List.rev_map convert_string cp @ prefix in + Some (lp, DP.make path) + with Exit -> None + in + let dirs = List.map_filter convert_dirs dirs in + let add_ml_dir = Mltop.add_ml_dir ~recursive:false in + let () = match lp.has_ml with + | AddNoML -> () + | AddTopML -> + Mltop.add_ml_dir ~recursive:false unix_path + | AddRecML -> + List.iter (fun (lp,_) -> add_ml_dir lp) dirs; + add_ml_dir unix_path in + let add (path, dir) = add_load_path path ~implicit dir in + let () = List.iter add dirs in + add_load_path unix_path ~implicit lp.coq_path + else + warn_cannot_open_path unix_path + +let add_coq_path { recursive; path_spec } = match path_spec with + | VoPath lp -> + add_vo_path ~recursive lp + | MlPath dir -> + Mltop.add_ml_dir ~recursive dir diff --git a/library/loadpath.mli b/vernac/loadpath.mli index 4044ca1127..6605daa8d2 100644 --- a/library/loadpath.mli +++ b/vernac/loadpath.mli @@ -20,19 +20,15 @@ open Names type t (** Type of loadpath bindings. *) -val physical : t -> CUnix.physical_path -(** Get the physical path (filesystem location) of a loadpath. *) - val logical : t -> DirPath.t (** Get the logical path (Coq module hierarchy) of a loadpath. *) +val pp : t -> Pp.t +(** Print a load path *) + val get_load_paths : unit -> t list (** Get the current loadpath association. *) -val add_load_path : CUnix.physical_path -> DirPath.t -> implicit:bool -> unit -(** [add_load_path phys log type] adds the binding [phys := log] to the current - loadpaths. *) - val remove_load_path : CUnix.physical_path -> unit (** Remove the current logical path binding associated to a given physical path, if any. *) @@ -41,17 +37,53 @@ val find_load_path : CUnix.physical_path -> t (** Get the binding associated to a physical path. Raises [Not_found] if there is none. *) -val is_in_load_paths : CUnix.physical_path -> bool -(** Whether a physical path is currently bound. *) - -val expand_path : ?root:DirPath.t -> DirPath.t -> (CUnix.physical_path * DirPath.t) list -(** Given a relative logical path, associate the list of absolute physical and - logical paths which are possible matches of it. *) - -val filter_path : (DirPath.t -> bool) -> (CUnix.physical_path * DirPath.t) list -(** As {!expand_path} but uses a filter function instead, and ignores the - implicit status of loadpaths. *) - val locate_file : string -> string (** Locate a file among the registered paths. Do not use this function, as it does not respect the visibility of paths. *) + +(** {6 Locate a library in the load path } *) +type library_location = LibLoaded | LibInPath +type locate_error = LibUnmappedDir | LibNotFound +type 'a locate_result = ('a, locate_error) result + +val locate_qualified_library + : ?root:DirPath.t + -> ?warn:bool + -> Libnames.qualid + -> (library_location * DirPath.t * CUnix.physical_path) locate_result + +(** Locates a library by implicit name. + + @raise LibUnmappedDir if the library is not in the path + @raise LibNotFound if there is no corresponding file in the path + +*) + +val try_locate_absolute_library : DirPath.t -> string + +(** {6 Extending the Load Path } *) + +(** Adds a path to the Coq and ML paths *) +type add_ml = AddNoML | AddTopML | AddRecML + +type vo_path_spec = { + unix_path : string; + (** Filesystem path containing vo/ml files *) + coq_path : Names.DirPath.t; + (** Coq prefix for the path *) + implicit : bool; + (** [implicit = true] avoids having to qualify with [coq_path] *) + has_ml : add_ml; + (** If [has_ml] is true, the directory will also be search for plugins *) +} + +type coq_path_spec = + | VoPath of vo_path_spec + | MlPath of string + +type coq_path = { + path_spec: coq_path_spec; + recursive: bool; +} + +val add_coq_path : coq_path -> unit diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 78e26c65d4..bbee9988d0 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -159,75 +159,9 @@ let add_ml_dir s = | _ -> () (* For Rec Add ML Path (-R) *) -let add_rec_ml_dir unix_path = - List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path) - -(* Adding files to Coq and ML loadpath *) - -let warn_cannot_use_directory = - CWarnings.create ~name:"cannot-use-directory" ~category:"filesystem" - (fun d -> - str "Directory " ++ str d ++ - strbrk " cannot be used as a Coq identifier (skipped)") - -let convert_string d = - try Names.Id.of_string d - with UserError _ -> - let d = Unicode.escaped_if_non_utf8 d in - warn_cannot_use_directory d; - raise Exit - -let warn_cannot_open_path = - CWarnings.create ~name:"cannot-open-path" ~category:"filesystem" - (fun unix_path -> str "Cannot open " ++ str unix_path) - -type add_ml = AddNoML | AddTopML | AddRecML - -type vo_path_spec = { - unix_path : string; - coq_path : Names.DirPath.t; - implicit : bool; - has_ml : add_ml; -} - -type coq_path_spec = - | VoPath of vo_path_spec - | MlPath of string - -type coq_path = { - path_spec: coq_path_spec; - recursive: bool; -} - -let add_vo_path ~recursive lp = - let unix_path = lp.unix_path in - let implicit = lp.implicit in - if exists_dir unix_path then - let dirs = if recursive then all_subdirs ~unix_path else [] in - let prefix = Names.DirPath.repr lp.coq_path in - let convert_dirs (lp, cp) = - try - let path = List.rev_map convert_string cp @ prefix in - Some (lp, Names.DirPath.make path) - with Exit -> None - in - let dirs = List.map_filter convert_dirs dirs in - let () = match lp.has_ml with - | AddNoML -> () - | AddTopML -> add_ml_dir unix_path - | AddRecML -> List.iter (fun (lp,_) -> add_ml_dir lp) dirs; add_ml_dir unix_path in - let add (path, dir) = - Loadpath.add_load_path path ~implicit dir in - let () = List.iter add dirs in - Loadpath.add_load_path unix_path ~implicit lp.coq_path - else - warn_cannot_open_path unix_path - -let add_coq_path { recursive; path_spec } = match path_spec with - | VoPath lp -> - add_vo_path ~recursive lp - | MlPath dir -> - if recursive then add_rec_ml_dir dir else add_ml_dir dir +let add_ml_dir ~recursive unix_path = + let dirs = if recursive then (all_subdirs ~unix_path) else [unix_path,[]] in + List.iter (fun (lp,_) -> add_ml_dir lp) dirs (* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = diff --git a/vernac/mltop.mli b/vernac/mltop.mli index 3d796aa4aa..b457c9c88f 100644 --- a/vernac/mltop.mli +++ b/vernac/mltop.mli @@ -32,6 +32,9 @@ val ocaml_toploop : unit -> unit (** {5 ML Dynlink} *) +(** Adds a dir to the plugin search path *) +val add_ml_dir : recursive:bool -> string -> unit + (** Tests if we can load ML files *) val has_dynlink : bool @@ -41,27 +44,6 @@ val dir_ml_load : string -> unit (** Dynamic interpretation of .ml *) val dir_ml_use : string -> unit -(** Adds a path to the Coq and ML paths *) -type add_ml = AddNoML | AddTopML | AddRecML - -type vo_path_spec = { - unix_path : string; (* Filesystem path contaning vo/ml files *) - coq_path : Names.DirPath.t; (* Coq prefix for the path *) - implicit : bool; (* [implicit = true] avoids having to qualify with [coq_path] *) - has_ml : add_ml; (* If [has_ml] is true, the directory will also be search for plugins *) -} - -type coq_path_spec = - | VoPath of vo_path_spec - | MlPath of string - -type coq_path = { - path_spec: coq_path_spec; - recursive: bool; -} - -val add_coq_path : coq_path -> unit - (** List of modules linked to the toplevel *) val add_known_module : string -> unit val module_is_known : string -> bool diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 46c4422d17..0d93e19723 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -331,7 +331,7 @@ let default_tactic = ref (Proofview.tclUNIT ()) let get_hide_obligations = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"Hidding of Program obligations" + ~name:"Hiding of Program obligations" ~key:["Hide";"Obligations"] ~value:false @@ -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 @@ -820,8 +820,8 @@ let solve_by_tac ?loc name evi t poly ctx = Pfedit.build_constant_by_tactic id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps evi.evar_concl t in let env = Global.env () in - let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in - let body, () = Future.force entry.const_entry_body in + let body = Future.force entry.const_entry_body in + let body = Safe_typing.inline_private_constants env body in let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in Inductiveops.control_only_guard env ctx' (EConstr.of_constr (fst body)); Some (fst body, entry.const_entry_type, Evd.evar_universe_context ctx') @@ -844,9 +844,9 @@ let obligation_terminator ?hook name num guard auto pf = | Admitted _ -> apply_terminator term pf | Proved (opq, id, { entries=[entry]; universes=uctx } ) -> begin let env = Global.env () in - let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in let ty = entry.Entries.const_entry_type in - let (body, cstr), () = Future.force entry.Entries.const_entry_body in + let body = Future.force entry.const_entry_body in + let (body, cstr) = Safe_typing.inline_private_constants env body in let sigma = Evd.from_ctx uctx in let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); @@ -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 f2332bab8b..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" @@ -911,7 +910,7 @@ open Pputils spc() ++ pr_class_rawexpr c2) ) - | VernacInstance (sup, (instid, bk, cl), props, info) -> + | VernacInstance (instid, sup, cl, props, info) -> return ( hov 1 ( keyword "Instance" ++ @@ -920,7 +919,6 @@ open Pputils | { v = Anonymous }, _ -> mt ()) ++ pr_and_type_binders_arg sup ++ str":" ++ spc () ++ - (match bk with Implicit -> str "! " | Explicit -> mt ()) ++ pr_constr env sigma cl ++ pr_hint_info (pr_constr_pattern_expr env sigma) info ++ (match props with | Some (true, { v = CRecord l}) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}" @@ -929,13 +927,12 @@ open Pputils | None -> mt())) ) - | VernacDeclareInstance (sup, (instid, bk, cl), info) -> + | VernacDeclareInstance (instid, sup, cl, info) -> return ( hov 1 ( keyword "Declare Instance" ++ spc () ++ pr_ident_decl instid ++ spc () ++ pr_and_type_binders_arg sup ++ str":" ++ spc () ++ - (match bk with Implicit -> str "! " | Explicit -> mt ()) ++ pr_constr env sigma cl ++ pr_hint_info (pr_constr_pattern_expr env sigma) info) ) @@ -1049,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() ++ @@ -1060,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 ()) ++ @@ -1088,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/search.ml b/vernac/search.ml index e41378908f..a5663d65ef 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -28,7 +28,7 @@ type display_function = GlobRef.t -> env -> constr -> unit [SearchAbout ...], etc. to the names of the symbols matching the query, separated by a newline. This type of output is useful for editors (like emacs), to generate a list of completion candidates -without having to parse thorugh the types of all symbols. *) +without having to parse through the types of all symbols. *) type glob_search_about_item = | GlobSearchSubPattern of constr_pattern diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 7f5c265eea..57c56a58f9 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -32,6 +32,7 @@ Assumptions Vernacstate Mltop Topfmt +Loadpath Vernacentries Misctypes diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 918852239a..af13c873e2 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 *) @@ -201,11 +225,6 @@ let show_match id = (* "Print" commands *) -let print_path_entry p = - let dir = DirPath.print (Loadpath.logical p) in - let path = str (CUnix.escaped_string_of_physical_path (Loadpath.physical p)) in - Pp.hov 2 (dir ++ spc () ++ path) - let print_loadpath dir = let l = Loadpath.get_load_paths () in let l = match dir with @@ -215,7 +234,7 @@ let print_loadpath dir = List.filter filter l in str "Logical Path / Physical path:" ++ fnl () ++ - prlist_with_sep fnl print_path_entry l + prlist_with_sep fnl Loadpath.pp l let print_modules () = let opened = Library.opened_libraries () @@ -410,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 @@ -444,9 +463,9 @@ let locate_file f = str file let msg_found_library = function - | Library.LibLoaded, fulldir, file -> + | Loadpath.LibLoaded, fulldir, file -> hov 0 (DirPath.print fulldir ++ strbrk " has been loaded from file " ++ str file) - | Library.LibInPath, fulldir, file -> + | Loadpath.LibInPath, fulldir, file -> hov 0 (DirPath.print fulldir ++ strbrk " is bound to file " ++ str file) let err_unmapped_library ?from qid = @@ -471,10 +490,11 @@ let err_notfound_library ?from qid = (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) let print_located_library qid = - try msg_found_library (Library.locate_qualified_library ~warn:false qid) - with - | Library.LibUnmappedDir -> err_unmapped_library qid - | Library.LibNotFound -> err_notfound_library qid + let open Loadpath in + match locate_qualified_library ~warn:false qid with + | Ok lib -> msg_found_library lib + | Error LibUnmappedDir -> err_unmapped_library qid + | Error LibNotFound -> err_notfound_library qid let smart_global r = let gr = Smartlocate.smart_global r in @@ -544,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 = @@ -566,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 -> @@ -577,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 begining of a proof. *) + 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 @@ -808,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 @@ -887,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) -> @@ -934,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) -> @@ -987,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 @@ -1001,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 @@ -1026,18 +1061,18 @@ let vernac_require from import qidl = Some (Libnames.add_dirpath_suffix hd tl) in let locate qid = - try - let warn = not !Flags.quiet in - let (_, dir, f) = Library.locate_qualified_library ?root ~warn qid in - (dir, f) - with - | Library.LibUnmappedDir -> err_unmapped_library ?from:root qid - | Library.LibNotFound -> err_notfound_library ?from:root qid + let open Loadpath in + let warn = not !Flags.quiet in + match locate_qualified_library ?root ~warn qid with + | Ok (_,dir,f) -> dir, f + | Error LibUnmappedDir -> err_unmapped_library ?from:root qid + | Error LibNotFound -> err_notfound_library ?from:root qid in let modrefl = List.map locate qidl in if Dumpglob.dump () then List.iter2 (fun {CAst.loc} dp -> Dumpglob.dump_libref ?loc dp "lib") qidl (List.map fst modrefl); - Library.require_library_from_dirpath modrefl import + let lib_resolver = Loadpath.try_locate_absolute_library in + Library.require_library_from_dirpath ~lib_resolver modrefl import (* Coercions and canonical structures *) @@ -1062,18 +1097,42 @@ let vernac_identity_coercion ~atts id qids qidt = (* Type classes *) -let vernac_instance ~atts sup inst props pri = - let open DefAttributes in - let global = not (make_section_locality atts.locality) in - Dumpglob.dump_constraint (fst (pi1 inst)) false "inst"; - let program_mode = atts.program in - Classes.new_instance ~program_mode ~global atts.polymorphic sup inst props pri +let vernac_instance_program ~atts name bl t props info = + Dumpglob.dump_constraint (fst name) false "inst"; + let (program, locality), polymorphic = + Attributes.(parse (Notations.(program ++ locality ++ polymorphic))) atts + in + let global = not (make_section_locality locality) in + 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_declare_instance ~atts sup inst pri = - let open DefAttributes in - let global = not (make_section_locality atts.locality) in - Dumpglob.dump_definition (fst (pi1 inst)) false "inst"; - Classes.declare_new_instance ~program_mode:atts.program ~global atts.polymorphic sup inst pri +let vernac_instance ~atts name bl t props info = + Dumpglob.dump_constraint (fst name) false "inst"; + let (program, locality), polymorphic = + Attributes.(parse (Notations.(program ++ locality ++ polymorphic))) atts + in + let global = not (make_section_locality locality) in + let _id : Id.t = + Classes.new_instance ~global polymorphic name bl t props info in + () + +let vernac_declare_instance ~atts id bl inst pri = + Dumpglob.dump_definition (fst id) false "inst"; + 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 @@ -1098,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 @@ -1122,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 *) @@ -1133,7 +1190,7 @@ let expand filename = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) filename let vernac_add_loadpath implicit pdir ldiropt = - let open Mltop in + let open Loadpath in let pdir = expand pdir in let alias = Option.default Libnames.default_root_prefix ldiropt in add_coq_path { recursive = true; @@ -1141,11 +1198,10 @@ let vernac_add_loadpath implicit pdir ldiropt = let vernac_remove_loadpath path = Loadpath.remove_load_path (expand path) - (* Coq syntax for ML or system commands *) let vernac_add_ml_path isrec path = - let open Mltop in + let open Loadpath in add_coq_path { recursive = isrec; path_spec = MlPath (expand path) } let vernac_declare_ml_module ~local l = @@ -1209,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 -> @@ -1221,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 @@ -1232,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 @@ -1290,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 @@ -1401,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 @@ -1433,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 () = { @@ -1877,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 () @@ -2034,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 @@ -2065,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 = @@ -2094,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 @@ -2135,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 = @@ -2154,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). *) @@ -2204,7 +2298,7 @@ let with_fail ~st f = try let _ = f () in raise HasNotFailed with | HasNotFailed as e -> raise e - | e -> + | e when CErrors.noncritical e || e = Timeout -> let e = CErrors.push e in raise (HasFailed (CErrors.iprint (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e))) @@ -2228,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 (sup, inst, props, info) -> - snd @@ with_def_attributes ~atts (vernac_instance ~pstate sup inst props info) - | VernacDeclareInstance (sup, inst, info) -> - with_def_attributes ~atts vernac_declare_instance sup inst info; - pstate + | VernacInstance (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) -> + 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 ?proof ~verbosely ~st fname + + (* Special: ?proof parameter doesn't allow for uniform pstate pop :S *) + | VernacEndProof e -> + unsupported_attributes atts; + vernac_end_proof ?proof ?pstate e + + | v -> + let fv = translate_vernac ~atts v in + interp_typed_vernac ~pstate fv (* XXX: This won't properly set the proof mode, as of today, it is controlled by the STM. Thus, we would need access information from diff --git a/vernac/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 23633e39ab..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 @@ -303,15 +302,17 @@ type nonrec vernac_expr = (* Type classes *) | VernacInstance of - local_binder_expr list * (* super *) - typeclass_constraint * (* instance name, class name, params *) - (bool * constr_expr) option * (* props *) - Hints.hint_info_expr + name_decl * (* name *) + local_binder_expr list * (* binders *) + constr_expr * (* type *) + (bool * constr_expr) option * (* body (bool=true when using {}) *) + Hints.hint_info_expr | VernacDeclareInstance of - local_binder_expr list * (* super *) - (ident_decl * Decl_kinds.binding_kind * constr_expr) * (* instance name, class name, params *) - Hints.hint_info_expr + ident_decl * (* name *) + local_binder_expr list * (* binders *) + constr_expr * (* type *) + Hints.hint_info_expr | VernacContext of local_binder_expr list @@ -360,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 54e08d0e95..60e371a6d9 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -22,7 +22,7 @@ a query like Check. The classification works on the assumption that we have 3 states: - parsing, execution (global enviroment, etc...), and proof + parsing, execution (global environment, etc...), and proof state. For example, commands that only alter the proof state are considered safe to delegate to a worker. @@ -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"] |