diff options
| -rwxr-xr-x | dev/tools/update-compat.py | 62 | ||||
| -rw-r--r-- | doc/sphinx/proof-engine/tactics.rst | 10 | ||||
| -rw-r--r-- | kernel/reduction.ml | 10 | ||||
| -rw-r--r-- | kernel/retypeops.ml | 30 | ||||
| -rw-r--r-- | kernel/retypeops.mli | 4 | ||||
| -rw-r--r-- | plugins/ssr/ssrbool.v | 2 | ||||
| -rw-r--r-- | pretyping/retyping.ml | 13 | ||||
| -rw-r--r-- | test-suite/output/Arguments.out | 14 | ||||
| -rw-r--r-- | test-suite/output/Arguments_renaming.out | 24 | ||||
| -rw-r--r-- | test-suite/output/Cases.out | 4 | ||||
| -rw-r--r-- | test-suite/output/Implicit.out | 2 | ||||
| -rw-r--r-- | test-suite/output/InitSyntax.out | 4 | ||||
| -rw-r--r-- | test-suite/output/PatternsInBinders.out | 2 | ||||
| -rw-r--r-- | test-suite/output/PrintInfos.out | 24 | ||||
| -rw-r--r-- | test-suite/output/UnivBinders.out | 2 | ||||
| -rw-r--r-- | vernac/comArguments.ml | 19 | ||||
| -rw-r--r-- | vernac/comArguments.mli | 2 | ||||
| -rw-r--r-- | vernac/g_vernac.mlg | 31 | ||||
| -rw-r--r-- | vernac/ppvernac.ml | 53 | ||||
| -rw-r--r-- | vernac/prettyp.ml | 26 | ||||
| -rw-r--r-- | vernac/vernacentries.ml | 4 | ||||
| -rw-r--r-- | vernac/vernacexpr.ml | 8 |
22 files changed, 196 insertions, 154 deletions
diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index c7bb36b6d3..7312c2a5af 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -1,6 +1,8 @@ -#!/usr/bin/env python2 +#!/usr/bin/env python3 from __future__ import with_statement +from __future__ import print_function import os, re, sys, subprocess +from io import open # When passed `--release`, this script sets up Coq to support three # `-compat` flag arguments. If executed manually, this would consist @@ -84,17 +86,25 @@ BUG_HEADER = r"""(* DO NOT MODIFY THIS FILE DIRECTLY *) (* It is autogenerated by %s. *) """ % os.path.relpath(os.path.realpath(__file__), ROOT_PATH) +def get_file_lines(file_name): + with open(file_name, 'rb') as f: + lines = f.readlines() + return [line.decode('utf-8') for line in lines] + +def get_file(file_name): + return ''.join(get_file_lines(file_name)) + def get_header(): - with open(HEADER_PATH, 'r') as f: return f.read() + return get_file(HEADER_PATH) HEADER = get_header() -def break_or_continue(): - msg = 'Press ENTER to continue, or Ctrl+C to break...' - try: - raw_input(msg) - except NameError: # we must be running python3 - input(msg) +def fatal_error(msg): + if hasattr(sys.stderr, 'buffer'): + sys.stderr.buffer.write(msg.encode("utf-8")) + else: + sys.stderr.write(msg.encode("utf-8")) + sys.exit(1) def maybe_git_add(local_path, suggest_add=True, **args): if args['git_add']: @@ -114,11 +124,10 @@ def maybe_git_rm(local_path, **args): def get_version(cur_version=None): if cur_version is not None: return cur_version - with open(CONFIGURE_PATH, 'r') as f: - for line in f.readlines(): - found = re.findall(r'let coq_version = "([0-9]+\.[0-9]+)', line) - if len(found) > 0: - return found[0] + for line in get_file_lines(CONFIGURE_PATH): + found = re.findall(r'let coq_version = "([0-9]+\.[0-9]+)', line) + if len(found) > 0: + return found[0] raise Exception("No line 'let coq_version = \"X.X' found in %s" % os.path.relpath(CONFIGURE_PATH, ROOT_PATH)) def compat_name_to_version_name(compat_file_name): @@ -132,8 +141,7 @@ def version_name_to_compat_name(v, ext='.v'): # returns (lines of compat files, lines of not compat files def get_doc_index_lines(): - with open(DOC_INDEX_PATH, 'r') as f: - lines = f.readlines() + lines = get_file_lines(DOC_INDEX_PATH) return (tuple(line for line in lines if 'theories/Compat/Coq' in line), tuple(line for line in lines if 'theories/Compat/Coq' not in line)) @@ -183,7 +191,7 @@ def update_if_changed(contents, new_contents, path, exn_string='%s changed!', su if contents is None or contents != new_contents: if not assert_unchanged: print('Updating %s...' % os.path.relpath(path, ROOT_PATH)) - with open(path, 'w') as f: + with open(path, 'w', encoding='utf-8') as f: f.write(new_contents) maybe_git_add(os.path.relpath(path, ROOT_PATH), suggest_add=suggest_add, **args) else: @@ -226,8 +234,7 @@ def update_compat_files(old_versions, new_versions, assert_unchanged=False, **ar update_file(contents, compat_path, exn_string='%s does not exist!', assert_unchanged=assert_unchanged, **args) else: # print('Checking %s...' % compat_file) - with open(compat_path, 'r') as f: - contents = f.read() + contents = get_file(compat_path) header = HEADER + (EXTRA_HEADER % v) if not contents.startswith(HEADER): raise Exception("Invalid header in %s; does not match %s" % (compat_file, os.path.relpath(HEADER_PATH, ROOT_PATH))) @@ -323,13 +330,13 @@ def check_no_old_versions(old_versions, new_versions, contents, relpath): raise Exception('Unreplaced usage of %s remaining in %s' % (V, relpath)) def update_flags_mli(old_versions, new_versions, **args): - with open(FLAGS_MLI_PATH, 'r') as f: contents = f.read() + contents = get_file(FLAGS_MLI_PATH) new_contents = update_compat_versions_type_line(new_versions, contents, os.path.relpath(FLAGS_MLI_PATH, ROOT_PATH)) check_no_old_versions(old_versions, new_versions, new_contents, os.path.relpath(FLAGS_MLI_PATH, ROOT_PATH)) update_if_changed(contents, new_contents, FLAGS_MLI_PATH, **args) def update_flags_ml(old_versions, new_versions, **args): - with open(FLAGS_ML_PATH, 'r') as f: contents = f.read() + contents = get_file(FLAGS_ML_PATH) new_contents = update_compat_versions_type_line(new_versions, contents, os.path.relpath(FLAGS_ML_PATH, ROOT_PATH)) new_contents = update_version_compare(new_versions, new_contents, os.path.relpath(FLAGS_ML_PATH, ROOT_PATH)) new_contents = update_pr_version(new_versions, new_contents, os.path.relpath(FLAGS_ML_PATH, ROOT_PATH)) @@ -337,13 +344,13 @@ def update_flags_ml(old_versions, new_versions, **args): update_if_changed(contents, new_contents, FLAGS_ML_PATH, **args) def update_coqargs_ml(old_versions, new_versions, **args): - with open(COQARGS_ML_PATH, 'r') as f: contents = f.read() + contents = get_file(COQARGS_ML_PATH) new_contents = update_add_compat_require(new_versions, contents, os.path.relpath(COQARGS_ML_PATH, ROOT_PATH)) check_no_old_versions(old_versions, new_versions, new_contents, os.path.relpath(COQARGS_ML_PATH, ROOT_PATH)) update_if_changed(contents, new_contents, COQARGS_ML_PATH, **args) def update_g_vernac(old_versions, new_versions, **args): - with open(G_VERNAC_PATH, 'r') as f: contents = f.read() + contents = get_file(G_VERNAC_PATH) new_contents = update_parse_compat_version(new_versions, contents, os.path.relpath(G_VERNAC_PATH, ROOT_PATH), **args) check_no_old_versions(old_versions, new_versions, new_contents, os.path.relpath(G_VERNAC_PATH, ROOT_PATH)) update_if_changed(contents, new_contents, G_VERNAC_PATH, **args) @@ -361,7 +368,7 @@ def update_test_suite(new_versions, assert_unchanged=False, test_suite_paths=TES contents = None suggest_add = False if os.path.exists(path): - with open(path, 'r') as f: contents = f.read() + contents = get_file(path) else: suggest_add = True if '%s' in descr: descr = descr % v @@ -376,7 +383,7 @@ def update_test_suite(new_versions, assert_unchanged=False, test_suite_paths=TES remove_if_exists(path, assert_unchanged=assert_unchanged, **args) def update_doc_index(new_versions, **args): - with open(DOC_INDEX_PATH, 'r') as f: contents = f.read() + contents = get_file(DOC_INDEX_PATH) firstline = ' theories/Compat/AdmitAxiom.v' new_contents = ''.join(DOC_INDEX_LINES) if firstline not in new_contents: @@ -386,7 +393,7 @@ def update_doc_index(new_versions, **args): update_if_changed(contents, new_contents, DOC_INDEX_PATH, **args) def update_test_suite_run(**args): - with open(TEST_SUITE_RUN_PATH, 'r') as f: contents = f.read() + contents = get_file(TEST_SUITE_RUN_PATH) new_contents = r'''#!/usr/bin/env bash # allow running this script from any directory by basing things on where the script lives @@ -410,7 +417,7 @@ def update_compat_notations(old_versions, new_versions, **args): for root, dirs, files in os.walk(os.path.join(ROOT_PATH, 'theories')): for fname in files: if not fname.endswith('.v'): continue - with open(os.path.join(root, fname), 'r') as f: contents = f.read() + contents = get_file(os.path.join(root, fname)) new_contents = update_compat_notations_in(old_versions, new_versions, contents) update_if_changed(contents, new_contents, os.path.join(root, fname), **args) @@ -435,9 +442,8 @@ def parse_args(argv): 'git_add': False, } if '--master' not in argv and '--release' not in argv: - print(r'''WARNING: You should pass either --release (sometime before branching) + fatal_error(r'''ERROR: You should pass either --release (sometime before branching) or --master (right after branching and updating the version number in version.ml)''') - if '--assert-unchanged' not in args: break_or_continue() for arg in argv[1:]: if arg == '--assert-unchanged': args['assert_unchanged'] = True diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 62d4aa704f..4f903d5776 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3281,11 +3281,13 @@ the conversion in hypotheses :n:`{+ @ident}`. defined transparent constant or local definition (see :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. + :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\iota\zeta`-normal form. + Use the general reduction tactics if you want to avoid this final + reduction, for instance :n:`cbv delta [@qualid]`. - .. exn:: @qualid does not denote an evaluable constant. + .. exn:: Cannot coerce @qualid to an evaluable reference. This error is frequent when trying to unfold something that has defined as an inductive type (or constructor) and not as a diff --git a/kernel/reduction.ml b/kernel/reduction.ml index f2cb9a8aec..b7bd4eef9a 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -302,7 +302,7 @@ let unfold_ref_with_args infos tab fl v = type conv_tab = { cnv_inf : clos_infos; - relevances : Sorts.relevance list; + relevances : Sorts.relevance Range.t; lft_tab : clos_tab; rgt_tab : clos_tab; } @@ -313,16 +313,16 @@ type conv_tab = { passed to each respective side of the conversion function below. *) let push_relevance infos r = - { infos with relevances = r.Context.binder_relevance :: infos.relevances } + { infos with relevances = Range.cons r.Context.binder_relevance infos.relevances } let push_relevances infos nas = - { infos with relevances = Array.fold_left (fun l x -> x.Context.binder_relevance :: l) infos.relevances nas } + { infos with relevances = Array.fold_left (fun l x -> Range.cons x.Context.binder_relevance l) infos.relevances nas } let rec skip_pattern infos relevances n c1 c2 = if Int.equal n 0 then {infos with relevances}, c1, c2 else match kind c1, kind c2 with | Lambda (x, _, c1), Lambda (_, _, c2) -> - skip_pattern infos (x.Context.binder_relevance :: relevances) (pred n) c1 c2 + skip_pattern infos (Range.cons x.Context.binder_relevance relevances) (pred n) c1 c2 | _ -> raise IrregularPatternShape let skip_pattern infos n c1 c2 = @@ -705,7 +705,7 @@ let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let infos = create_clos_infos ~evars reds env in let infos = { cnv_inf = infos; - relevances = List.map Context.Rel.Declaration.get_relevance (rel_context env); + relevances = Range.empty; lft_tab = create_tab (); rgt_tab = create_tab (); } in diff --git a/kernel/retypeops.ml b/kernel/retypeops.ml index 5c15257511..6a1b36ea94 100644 --- a/kernel/retypeops.ml +++ b/kernel/retypeops.ml @@ -39,16 +39,10 @@ let relevance_of_projection env p = let mib = lookup_mind mind env in Declareops.relevance_of_projection_repr mib (Projection.repr p) -let rec relevance_of_rel_extra env extra n = - match extra with - | [] -> relevance_of_rel env n - | r :: _ when Int.equal n 1 -> r - | _ :: extra -> relevance_of_rel_extra env extra (n-1) - -let relevance_of_flex env extra lft = function +let relevance_of_flex env = function | ConstKey (c,_) -> relevance_of_constant env c | VarKey x -> relevance_of_var env x - | RelKey p -> relevance_of_rel_extra env extra (Esubst.reloc_rel p lft) + | RelKey p -> relevance_of_rel env p let rec relevance_of_fterm env extra lft f = let open CClosure in @@ -57,9 +51,9 @@ let rec relevance_of_fterm env extra lft f = | KnownI -> Sorts.Irrelevant | Unknown -> let r = match fterm_of f with - | FRel n -> relevance_of_rel_extra env extra (Esubst.reloc_rel n lft) + | FRel n -> Range.get extra (Esubst.reloc_rel n lft - 1) | FAtom c -> relevance_of_term_extra env extra lft (Esubst.subs_id 0) c - | FFlex key -> relevance_of_flex env extra lft key + | FFlex key -> relevance_of_flex env key | FInt _ | FFloat _ -> Sorts.Relevant | FInd _ | FProd _ -> Sorts.Relevant (* types are always relevant *) | FConstruct (c,_) -> relevance_of_constructor env c @@ -69,12 +63,12 @@ let rec relevance_of_fterm env extra lft f = | FCoFix ((i,(lna,_,_)), _) -> (lna.(i)).binder_relevance | FCaseT (ci, _, _, _, _) -> ci.ci_relevance | FLambda (len, tys, bdy, e) -> - let extra = List.rev_append (List.map (fun (x,_) -> binder_relevance x) tys) extra in + let extra = List.fold_left (fun accu (x, _) -> Range.cons (binder_relevance x) accu) extra tys in let lft = Esubst.el_liftn len lft in let e = Esubst.subs_liftn len e in relevance_of_term_extra env extra lft e bdy | FLetIn (x, _, _, bdy, e) -> - relevance_of_term_extra env (x.binder_relevance :: extra) + relevance_of_term_extra env (Range.cons x.binder_relevance extra) (Esubst.el_lift lft) (Esubst.subs_lift e) bdy | FLIFT (k, f) -> relevance_of_fterm env extra (Esubst.el_shft k lft) f | FCLOS (c, e) -> relevance_of_term_extra env extra lft e c @@ -88,16 +82,18 @@ let rec relevance_of_fterm env extra lft f = and relevance_of_term_extra env extra lft subs c = match kind c with | Rel n -> - (match Esubst.expand_rel n subs with + begin match Esubst.expand_rel n subs with | Inl (k, f) -> relevance_of_fterm env extra (Esubst.el_liftn k lft) f - | Inr (n, _) -> relevance_of_rel_extra env extra (Esubst.reloc_rel n lft)) + | Inr (n, None) -> Range.get extra (Esubst.reloc_rel n lft - 1) + | Inr (_, Some p) -> relevance_of_rel env p + end | Var x -> relevance_of_var env x | Sort _ | Ind _ | Prod _ -> Sorts.Relevant (* types are always relevant *) | Cast (c, _, _) -> relevance_of_term_extra env extra lft subs c | Lambda ({binder_relevance=r;_}, _, bdy) -> - relevance_of_term_extra env (r::extra) (Esubst.el_lift lft) (Esubst.subs_lift subs) bdy + relevance_of_term_extra env (Range.cons r extra) (Esubst.el_lift lft) (Esubst.subs_lift subs) bdy | LetIn ({binder_relevance=r;_}, _, _, bdy) -> - relevance_of_term_extra env (r::extra) (Esubst.el_lift lft) (Esubst.subs_lift subs) bdy + relevance_of_term_extra env (Range.cons r extra) (Esubst.el_lift lft) (Esubst.subs_lift subs) bdy | App (c, _) -> relevance_of_term_extra env extra lft subs c | Const (c,_) -> relevance_of_constant env c | Construct (c,_) -> relevance_of_constructor env c @@ -115,5 +111,5 @@ let relevance_of_fterm env extra lft c = let relevance_of_term env c = if Environ.sprop_allowed env - then relevance_of_term_extra env [] Esubst.el_id (Esubst.subs_id 0) c + then relevance_of_term_extra env Range.empty Esubst.el_id (Esubst.subs_id 0) c else Sorts.Relevant diff --git a/kernel/retypeops.mli b/kernel/retypeops.mli index f4497be44b..dd4513959f 100644 --- a/kernel/retypeops.mli +++ b/kernel/retypeops.mli @@ -14,14 +14,14 @@ val relevance_of_term : Environ.env -> Constr.constr -> Sorts.relevance -val relevance_of_fterm : Environ.env -> Sorts.relevance list -> +val relevance_of_fterm : Environ.env -> Sorts.relevance Range.t -> Esubst.lift -> CClosure.fconstr -> Sorts.relevance (** Helpers *) open Names -val relevance_of_rel_extra : Environ.env -> Sorts.relevance list -> int -> Sorts.relevance +val relevance_of_rel : Environ.env -> int -> Sorts.relevance val relevance_of_var : Environ.env -> Id.t -> Sorts.relevance val relevance_of_constant : Environ.env -> Constant.t -> Sorts.relevance val relevance_of_constructor : Environ.env -> constructor -> Sorts.relevance diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index 376410658a..f6b192c226 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -290,7 +290,7 @@ Require Import ssreflect ssrfun. r -- a right-hand operation, as orb_andr : rightt_distributive orb andb. T or t -- boolean truth, as in andbT: right_id true andb. U -- predicate union, as in predU. - W -- weakening, as in in1W : {in D, forall x, P} -> forall x, P. **) + W -- weakening, as in in1W : (forall x, P) -> {in D, forall x, P}. **) Set Implicit Arguments. diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index f089b242a2..d2af957b54 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -264,16 +264,19 @@ let relevance_of_term env sigma c = if Environ.sprop_allowed env then let rec aux rels c = match kind sigma c with - | Rel n -> Retypeops.relevance_of_rel_extra env rels n + | Rel n -> + let len = Range.length rels in + if n <= len then Range.get rels (n - 1) + else Retypeops.relevance_of_rel env (n - len) | Var x -> Retypeops.relevance_of_var env x | Sort _ -> Sorts.Relevant | Cast (c, _, _) -> aux rels c | Prod ({binder_relevance=r}, _, codom) -> - aux (r::rels) codom + aux (Range.cons r rels) codom | Lambda ({binder_relevance=r}, _, bdy) -> - aux (r::rels) bdy + aux (Range.cons r rels) bdy | LetIn ({binder_relevance=r}, _, _, bdy) -> - aux (r::rels) bdy + aux (Range.cons r rels) bdy | App (c, _) -> aux rels c | Const (c,_) -> Retypeops.relevance_of_constant env c | Ind _ -> Sorts.Relevant @@ -287,7 +290,7 @@ let relevance_of_term env sigma c = | Meta _ | Evar _ -> Sorts.Relevant in - aux [] c + aux Range.empty c else Sorts.Relevant let relevance_of_type env sigma t = diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 6704337f80..f889da4e98 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -1,7 +1,7 @@ Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic -Arguments Nat.sub _%nat_scope _%nat_scope : simpl nomatch +Arguments Nat.sub (_ _)%nat_scope : simpl nomatch The reduction tactics unfold Nat.sub but avoid exposing match constructs Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub @@ -25,7 +25,7 @@ Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic -Arguments Nat.sub !_%nat_scope !_%nat_scope / +Arguments Nat.sub (!_ !_)%nat_scope / The reduction tactics unfold Nat.sub when the 1st and 2nd arguments evaluate to a constructor and when applied to 2 arguments Nat.sub is transparent @@ -33,7 +33,7 @@ Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic -Arguments Nat.sub !_%nat_scope !_%nat_scope +Arguments Nat.sub (!_ !_)%nat_scope The reduction tactics unfold Nat.sub when the 1st and 2nd arguments evaluate to a constructor Nat.sub is transparent @@ -43,14 +43,14 @@ forall D1 C1 : Type, (D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2 pf is not universe polymorphic -Arguments pf {D1%foo_scope} {C1%type_scope} _ [D2] [C2] : simpl never +Arguments pf {D1}%foo_scope {C1}%type_scope _ [D2 C2] : simpl never The reduction tactics never unfold pf pf is transparent Expands to: Constant Arguments.pf fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C fcomp is not universe polymorphic -Arguments fcomp {A%type_scope} {B%type_scope} {C%type_scope} _ _ _ / +Arguments fcomp {A B C}%type_scope _ _ _ / The reduction tactics unfold fcomp when applied to 6 arguments fcomp is transparent Expands to: Constant Arguments.fcomp @@ -78,7 +78,7 @@ Expands to: Constant Arguments.S1.S2.f f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic -Arguments f [T2%type_scope] _ _ !_%nat_scope !_ !_%nat_scope +Arguments f [T2]%type_scope _ _ !_%nat_scope !_ !_%nat_scope The reduction tactics unfold f when the 4th, 5th and 6th arguments evaluate to a constructor f is transparent @@ -86,7 +86,7 @@ Expands to: Constant Arguments.S1.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic -Arguments f [T1%type_scope] [T2%type_scope] _ _ !_%nat_scope !_ !_%nat_scope +Arguments f [T1 T2]%type_scope _ _ !_%nat_scope !_ !_%nat_scope The reduction tactics unfold f when the 5th, 6th and 7th arguments evaluate to a constructor f is transparent diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 53d5624f6f..5093e785de 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -13,21 +13,21 @@ where ?y : [ |- nat] Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x -Arguments eq {A%type_scope} -Arguments eq_refl {B%type_scope} {y}, [B] _ +Arguments eq {A}%type_scope +Arguments eq_refl {B}%type_scope {y}, [B] _ eq_refl : forall (A : Type) (x : A), x = x eq_refl is not universe polymorphic -Arguments eq_refl {B%type_scope} {y}, [B] _ +Arguments eq_refl {B}%type_scope {y}, [B] _ Expands to: Constructor Coq.Init.Logic.eq_refl Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x Arguments myEq _%type_scope -Arguments myrefl {C%type_scope} x : rename +Arguments myrefl {C}%type_scope x : rename myrefl : forall (B : Type) (x : A), B -> myEq B x x myrefl is not universe polymorphic -Arguments myrefl {C%type_scope} x : rename +Arguments myrefl {C}%type_scope x : rename Expands to: Constructor Arguments_renaming.Test1.myrefl myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := @@ -37,11 +37,11 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat -Arguments myplus {Z%type_scope} !t !n%nat_scope m%nat_scope : rename +Arguments myplus {Z}%type_scope !t (!n m)%nat_scope : rename myplus : forall T : Type, T -> nat -> nat -> nat myplus is not universe polymorphic -Arguments myplus {Z%type_scope} !t !n%nat_scope m%nat_scope : rename +Arguments myplus {Z}%type_scope !t (!n m)%nat_scope : rename The reduction tactics unfold myplus when the 2nd and 3rd arguments evaluate to a constructor myplus is transparent @@ -51,12 +51,12 @@ Expands to: Constant Arguments_renaming.Test1.myplus Inductive myEq (A B : Type) (x : A) : A -> Prop := myrefl : B -> myEq A B x x -Arguments myEq _%type_scope _%type_scope -Arguments myrefl A%type_scope {C%type_scope} x : rename +Arguments myEq (_ _)%type_scope +Arguments myrefl A%type_scope {C}%type_scope x : rename myrefl : forall (A B : Type) (x : A), B -> myEq A B x x myrefl is not universe polymorphic -Arguments myrefl A%type_scope {C%type_scope} x : rename +Arguments myrefl A%type_scope {C}%type_scope x : rename Expands to: Constructor Arguments_renaming.myrefl myrefl : forall (A C : Type) (x : A), C -> myEq A C x x @@ -68,11 +68,11 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat -Arguments myplus {Z%type_scope} !t !n%nat_scope m%nat_scope : rename +Arguments myplus {Z}%type_scope !t (!n m)%nat_scope : rename myplus : forall T : Type, T -> nat -> nat -> nat myplus is not universe polymorphic -Arguments myplus {Z%type_scope} !t !n%nat_scope m%nat_scope : rename +Arguments myplus {Z}%type_scope !t (!n m)%nat_scope : rename The reduction tactics unfold myplus when the 2nd and 3rd arguments evaluate to a constructor myplus is transparent diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 7489b8987e..e84ac85aa8 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -7,7 +7,7 @@ fix F (t : t) : P t := : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t -Arguments t_rect _%function_scope _%function_scope +Arguments t_rect (_ _)%function_scope = fun d : TT => match d with | {| f3 := b |} => b end @@ -26,7 +26,7 @@ match Nat.eq_dec x y with end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y -Arguments proj _%nat_scope _%nat_scope _%function_scope +Arguments proj (_ _)%nat_scope _%function_scope foo = fix foo (A : Type) (l : list A) {struct l} : option A := match l with diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index d65d2a8f55..5f22eb5d7c 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -5,7 +5,7 @@ ex_intro (P:=fun _ : nat => True) (x:=0) I d2 = fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x -Arguments d2 [x%nat_scope] [x0%nat_scope] +Arguments d2 [x x0]%nat_scope map id (1 :: nil) : list nat map id' (1 :: nil) diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index ce058a6d34..da255e86cd 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -1,8 +1,8 @@ Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x} -Arguments sig2 [A%type_scope] _%type_scope _%type_scope -Arguments exist2 [A%type_scope] _%function_scope _%function_scope +Arguments sig2 [A]%type_scope (_ _)%type_scope +Arguments exist2 [A]%type_scope (_ _)%function_scope exists x : nat, x = x : Prop fun b : bool => if b then b else b diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out index 2952b6d94b..4f09f00c56 100644 --- a/test-suite/output/PatternsInBinders.out +++ b/test-suite/output/PatternsInBinders.out @@ -15,7 +15,7 @@ swap = fun (A B : Type) '(x, y) => (y, x) : forall A B : Type, A * B -> B * A -Arguments swap {A%type_scope} {B%type_scope} +Arguments swap {A B}%type_scope fun (A B : Type) '(x, y) => swap (x, y) = (y, x) : forall A B : Type, A * B -> Prop forall (A B : Type) '(x, y), swap (x, y) = (y, x) diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index 7d0d81a3e8..71d162c314 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -1,24 +1,24 @@ existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} existT is template universe polymorphic on sigT.u0 sigT.u1 -Arguments existT [A%type_scope] _%function_scope +Arguments existT [A]%type_scope _%function_scope Expands to: Constructor Coq.Init.Specif.existT Inductive sigT (A : Type) (P : A -> Type) : Type := existT : forall x : A, P x -> {x : A & P x} -Arguments sigT [A%type_scope] _%type_scope -Arguments existT [A%type_scope] _%function_scope +Arguments sigT [A]%type_scope _%type_scope +Arguments existT [A]%type_scope _%function_scope existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x -Arguments eq {A%type_scope} -Arguments eq_refl {A%type_scope} {x}, [A] _ +Arguments eq {A}%type_scope +Arguments eq_refl {A}%type_scope {x}, [A] _ eq_refl : forall (A : Type) (x : A), x = x eq_refl is not universe polymorphic -Arguments eq_refl {A%type_scope} {x}, [A] _ +Arguments eq_refl {A}%type_scope {x}, [A] _ Expands to: Constructor Coq.Init.Logic.eq_refl eq_refl : forall (A : Type) (x : A), x = x @@ -34,11 +34,11 @@ fix add (n m : nat) {struct n} : nat := end : nat -> nat -> nat -Arguments Nat.add _%nat_scope _%nat_scope +Arguments Nat.add (_ _)%nat_scope Nat.add : nat -> nat -> nat Nat.add is not universe polymorphic -Arguments Nat.add _%nat_scope _%nat_scope +Arguments Nat.add (_ _)%nat_scope Nat.add is transparent Expands to: Constant Coq.Init.Nat.add Nat.add : nat -> nat -> nat @@ -52,9 +52,9 @@ Expands to: Constant Coq.Init.Peano.plus_n_O Inductive le (n : nat) : nat -> Prop := le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m -Arguments le _%nat_scope _%nat_scope +Arguments le (_ _)%nat_scope Arguments le_n _%nat_scope -Arguments le_S {n%nat_scope} [m%nat_scope] +Arguments le_S {n}%nat_scope [m]%nat_scope comparison : Set comparison is not universe polymorphic @@ -80,8 +80,8 @@ Notation sym_eq := eq_sym Expands to: Notation Coq.Init.Logic.sym_eq Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x -Arguments eq {A%type_scope} -Arguments eq_refl {A%type_scope} {x}, {A} _ +Arguments eq {A}%type_scope +Arguments eq_refl {A}%type_scope {x}, {A} _ n:nat Hypothesis of the goal context. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 298a0789c4..525ca48bee 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -33,7 +33,7 @@ fun (A : Type@{u}) (Wrap : Wrap@{u} A) => Wrap : forall A : Type@{u}, Wrap@{u} A -> A (* u |= *) -Arguments wrap {A%type_scope} {Wrap} +Arguments wrap {A}%type_scope {Wrap} bar@{u} = nat : Wrap@{u} Set (* u |= Set < u *) diff --git a/vernac/comArguments.ml b/vernac/comArguments.ml index 737e0427ec..15077298aa 100644 --- a/vernac/comArguments.ml +++ b/vernac/comArguments.ml @@ -60,7 +60,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 nargs_before_bidi flags = +let vernac_arguments ~section_local reference args more_implicits flags = let env = Global.env () in let sigma = Evd.from_env env in let assert_flag = List.mem `Assert flags in @@ -83,6 +83,23 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red if clear_implicits_flag && default_implicits_flag then err_incompat "clear implicits" "default implicits"; + let args, nargs_for_red, nargs_before_bidi, _i = + List.fold_left (fun (args,red,bidi,i) arg -> + match arg with + | RealArg arg -> (arg::args,red,bidi,i+1) + | VolatileArg -> + if Option.has_some red + then CErrors.user_err Pp.(str "The \"/\" modifier may only occur once."); + (args,Some i,bidi,i) + | BidiArg -> + if Option.has_some bidi + then CErrors.user_err Pp.(str "The \"&\" modifier may only occur once."); + (args,red,Some i,i)) + ([],None,None,0) + args + in + let args = List.rev args in + let sr = smart_global reference in let inf_names = let ty, _ = Typeops.type_of_global_in_context env sr in diff --git a/vernac/comArguments.mli b/vernac/comArguments.mli index f78e01a11f..71effddf67 100644 --- a/vernac/comArguments.mli +++ b/vernac/comArguments.mli @@ -13,7 +13,5 @@ val vernac_arguments -> Libnames.qualid Constrexpr.or_by_notation -> Vernacexpr.vernac_argument_status list -> (Names.Name.t * Impargs.implicit_kind) list list - -> int option - -> int option -> Vernacexpr.arguments_modifier list -> unit diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 0515e88a15..5b97e06b2b 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -781,25 +781,8 @@ 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 - | `Slash :: args -> - if Option.is_empty !slash_position then - (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, !ampersand_position, mods) } + VernacArguments (qid, List.flatten args, more_implicits, mods) } | IDENT "Implicit"; "Type"; bl = reserv_list -> { VernacReserve bl } @@ -843,17 +826,17 @@ GRAMMAR EXTEND Gram argument_spec_block: [ [ item = argument_spec -> { let name, recarg_like, notation_scope = item in - [`Id { name=name; recarg_like=recarg_like; + [RealArg { name=name; recarg_like=recarg_like; notation_scope=notation_scope; implicit_status = NotImplicit}] } - | "/" -> { [`Slash] } - | "&" -> { [`Ampersand] } + | "/" -> { [VolatileArg] } + | "&" -> { [BidiArg] } | "("; items = LIST1 argument_spec; ")"; sc = OPT scope_delimiter -> { let f x = match sc, x with | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc y) x | Some _, Some _ -> user_err Pp.(str "scope declared twice") in List.map (fun (name,recarg_like,notation_scope) -> - `Id { name=name; recarg_like=recarg_like; + RealArg { name=name; recarg_like=recarg_like; notation_scope=f notation_scope; implicit_status = NotImplicit}) items } | "["; items = LIST1 argument_spec; "]"; sc = OPT scope_delimiter -> @@ -861,7 +844,7 @@ GRAMMAR EXTEND Gram | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc y) x | Some _, Some _ -> user_err Pp.(str "scope declared twice") in List.map (fun (name,recarg_like,notation_scope) -> - `Id { name=name; recarg_like=recarg_like; + RealArg { name=name; recarg_like=recarg_like; notation_scope=f notation_scope; implicit_status = Implicit}) items } | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope_delimiter -> @@ -869,7 +852,7 @@ GRAMMAR EXTEND Gram | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc y) x | Some _, Some _ -> user_err Pp.(str "scope declared twice") in List.map (fun (name,recarg_like,notation_scope) -> - `Id { name=name; recarg_like=recarg_like; + RealArg { name=name; recarg_like=recarg_like; notation_scope=f notation_scope; implicit_status = MaximallyImplicit}) items } ] diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 3dbf7afb78..080629ede2 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -1068,39 +1068,52 @@ let string_of_definition_object_kind = let open Decls in function | Some Flags.Current -> [SetOnlyParsing] | Some v -> [SetCompatVersion v])) ) - | VernacArguments (q, args, more_implicits, nargs, nargs_before_bidi, mods) -> + | VernacArguments (q, args, more_implicits, mods) -> return ( hov 2 ( keyword "Arguments" ++ spc() ++ pr_smart_global q ++ let pr_s = function None -> str"" | Some {v=s} -> str "%" ++ str s in let pr_if b x = if b then x else str "" in - let pr_br imp x = match imp with - | Impargs.Implicit -> str "[" ++ x ++ str "]" - | Impargs.MaximallyImplicit -> str "{" ++ x ++ str "}" - | Impargs.NotImplicit -> x in - 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 - | None, None, [] -> mt() - | _, _, [] -> - let dummy = {name=Anonymous; recarg_like=false; - notation_scope=None; implicit_status=Impargs.NotImplicit} - in - print_arguments n nbidi [dummy] - | n, nbidi, { name = id; recarg_like = k; + let pr_one_arg (x,k) = pr_if k (str"!") ++ Name.print x in + let pr_br imp force x = + let left,right = + match imp with + | Impargs.Implicit -> str "[", str "]" + | Impargs.MaximallyImplicit -> str "{", str "}" + | Impargs.NotImplicit -> if force then str"(",str")" else mt(),mt() + in + left ++ x ++ right + in + let get_arguments_like s imp tl = + if s = None && imp = Impargs.NotImplicit then [], tl + else + let rec fold extra = function + | RealArg arg :: tl when + Option.equal (fun a b -> String.equal a.CAst.v b.CAst.v) arg.notation_scope s + && arg.implicit_status = imp -> + fold ((arg.name,arg.recarg_like) :: extra) tl + | args -> List.rev extra, args + in + fold [] tl + in + let rec print_arguments = function + | [] -> mt() + | VolatileArg :: l -> spc () ++ str"/" ++ print_arguments l + | BidiArg :: l -> spc () ++ str"&" ++ print_arguments l + | RealArg { 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) (Option.map pred nbidi) tl + let extra, tl = get_arguments_like s imp tl in + spc() ++ pr_br imp (extra<>[]) (prlist_with_sep spc pr_one_arg ((id,k)::extra)) ++ + pr_s s ++ print_arguments tl in let rec print_implicits = function | [] -> mt () | (name, impl) :: rest -> - spc() ++ pr_br impl (Name.print name) ++ print_implicits rest + spc() ++ pr_br impl false (Name.print name) ++ print_implicits rest in - print_arguments nargs nargs_before_bidi args ++ + print_arguments args ++ if not (List.is_empty more_implicits) then prlist (fun l -> str"," ++ print_implicits l) more_implicits else (mt ()) ++ diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index 5ebc89892c..ea49cae9db 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -259,6 +259,13 @@ let implicit_kind_of_status = function | None -> Anonymous, NotImplicit | Some (id,_,(maximal,_)) -> Name id, if maximal then MaximallyImplicit else Implicit +let dummy = { + Vernacexpr.implicit_status = NotImplicit; + name = Anonymous; + recarg_like = false; + notation_scope = None; +} + let is_dummy {Vernacexpr.implicit_status; name; recarg_like; notation_scope} = name = Anonymous && not recarg_like && notation_scope = None && implicit_status = NotImplicit @@ -287,6 +294,20 @@ let rec main_implicits i renames recargs scopes impls = then [] (* we may have a trail of dummies due to eg "clear scopes" *) else status :: rest +let rec insert_fake_args volatile bidi impls = + let open Vernacexpr in + match volatile, bidi with + | Some 0, _ -> VolatileArg :: insert_fake_args None bidi impls + | _, Some 0 -> BidiArg :: insert_fake_args volatile None impls + | None, None -> List.map (fun a -> RealArg a) impls + | _, _ -> + let hd, tl = match impls with + | impl :: impls -> impl, impls + | [] -> dummy, [] + in + let f = Option.map pred in + RealArg hd :: insert_fake_args (f volatile) (f bidi) tl + let print_arguments ref = let qid = Nametab.shortest_qualid_of_global Id.Set.empty ref in let flags, recargs, nargs_for_red = @@ -312,12 +333,13 @@ let print_arguments ref = let impls = main_implicits 0 renames recargs scopes impls in let moreimpls = List.map (fun (_,i) -> List.map implicit_kind_of_status i) moreimpls in let bidi = Pretyping.get_bidirectionality_hint ref in - if impls = [] && moreimpls = [] && nargs_for_red = None && bidi = None && flags = [] then [] + let impls = insert_fake_args nargs_for_red bidi impls in + if impls = [] && moreimpls = [] && flags = [] then [] else let open Constrexpr in let open Vernacexpr in [Ppvernac.pr_vernac_expr - (VernacArguments (CAst.make (AN qid), impls, moreimpls, nargs_for_red, bidi, flags))] + (VernacArguments (CAst.make (AN qid), impls, moreimpls, flags))] let print_name_infos ref = let type_info_for_implicit = diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index f56cc00c3b..535aceed15 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -2167,10 +2167,10 @@ let translate_vernac ~atts v = let open Vernacextend in match v with vernac_hints ~atts dbnames hints) | VernacSyntacticDefinition (id,c,b) -> VtDefault(fun () -> vernac_syntactic_definition ~atts id c b) - | VernacArguments (qid, args, more_implicits, nargs, bidi, flags) -> + | VernacArguments (qid, args, more_implicits, flags) -> VtDefault(fun () -> with_section_locality ~atts - (ComArguments.vernac_arguments qid args more_implicits nargs bidi flags)) + (ComArguments.vernac_arguments qid args more_implicits flags)) | VernacReserve bl -> VtDefault(fun () -> unsupported_attributes atts; diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 564c55670d..ce96d9265c 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -250,13 +250,17 @@ type vernac_cumulative = VernacCumulative | VernacNonCumulative (** {6 The type of vernacular expressions} *) -type vernac_argument_status = { +type vernac_one_argument_status = { name : Name.t; recarg_like : bool; notation_scope : string CAst.t option; implicit_status : Impargs.implicit_kind; } +type vernac_argument_status = + | VolatileArg | BidiArg + | RealArg of vernac_one_argument_status + type arguments_modifier = [ `Assert | `ClearBidiHint @@ -383,8 +387,6 @@ type nonrec vernac_expr = qualid or_by_notation * 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 *) * arguments_modifier list | VernacReserve of simple_binder list | VernacGeneralizable of (lident list) option |
