From 297b0cb44bbe8ec7304ca635c566815167266d4a Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 24 Jun 2015 11:28:44 +0200 Subject: Revert commit 18796b6aea453bdeef1ad12ce80eeb220bf01e67, close 3080 This reverts 18796b6aea453bdeef1ad12ce80eeb220bf01e67 (Slight change in the semantics of arguments scopes: scopes can no longer be bound to Funclass or Sortclass (this does not seem to be useful)). It is useful to have function_scope for, e.g., function composition. This allows users to, e.g., automatically interpret ∘ as morphism composition when expecting a morphism of categories, as functor composition when expecting a functor, and as function composition when expecting a function. Additionally, it is nicer to have fewer special cases in the OCaml code, and give more things a uniform syntax. (The scope type_scope should not be special-cased; this change is coming up next.) Also explicitly define [function_scope] in theories/Init/Notations.v. This closes bug #3080, Build a [function_scope] like [type_scope], or allow [Bind Scope ... with Sortclass] and [Bind Scope ... with Funclass] We now mention Funclass and Sortclass in the documentation of [Bind Scope] again. --- test-suite/output/Cases.out | 4 +++- test-suite/output/InitSyntax.out | 3 ++- test-suite/output/PrintInfos.out | 4 ++-- 3 files changed, 7 insertions(+), 4 deletions(-) (limited to 'test-suite') diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 09f032d478..92e70cf1cb 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -6,6 +6,8 @@ fix F (t : t) : P t := end : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t + +Argument scopes are [function_scope function_scope _] = fun d : TT => match d with | @CTT _ _ b => b end @@ -24,7 +26,7 @@ match Nat.eq_dec x y with end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y -Argument scopes are [nat_scope nat_scope _ _ _] +Argument scopes are [nat_scope 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/InitSyntax.out b/test-suite/output/InitSyntax.out index bbfd3405af..c17c63e724 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -4,7 +4,8 @@ Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := For sig2: Argument A is implicit For exist2: Argument A is implicit For sig2: Argument scopes are [type_scope type_scope type_scope] -For exist2: Argument scopes are [type_scope _ _ _ _ _] +For exist2: Argument scopes are [type_scope function_scope function_scope _ _ + _] exists x : nat, x = x : Prop fun b : bool => if b then b else b diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index ba076f050a..98420409e8 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -2,7 +2,7 @@ existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} existT is template universe polymorphic Argument A is implicit -Argument scopes are [type_scope _ _ _] +Argument scopes are [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} @@ -10,7 +10,7 @@ Inductive sigT (A : Type) (P : A -> Type) : Type := For sigT: Argument A is implicit For existT: Argument A is implicit For sigT: Argument scopes are [type_scope type_scope] -For existT: Argument scopes are [type_scope _ _ _] +For existT: Argument scopes are [type_scope function_scope _ _] existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit -- cgit v1.2.3 From 6aa58955515dff338ea85d59073dfc0d0c7648ab Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Wed, 24 Jun 2015 15:41:11 +0200 Subject: Move type_scope into user space, fix some output logs --- test-suite/bugs/closed/3080.v | 18 ++++++++++++++++++ test-suite/bugs/closed/3612.v | 2 ++ test-suite/bugs/closed/3649.v | 4 +++- 3 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/3080.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3080.v b/test-suite/bugs/closed/3080.v new file mode 100644 index 0000000000..7d0dc090e1 --- /dev/null +++ b/test-suite/bugs/closed/3080.v @@ -0,0 +1,18 @@ +(* -*- coq-prog-args: ("-emacs" "-nois") -*- *) +Delimit Scope type_scope with type. +Delimit Scope function_scope with function. + +Bind Scope type_scope with Sortclass. +Bind Scope function_scope with Funclass. + +Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). +Notation "A -> B" := (forall (_ : A), B) : type_scope. + +Definition compose {A B C} (g : B -> C) (f : A -> B) := + fun x : A => g (f x). + +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] *) diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v index 9125ab16dd..324c12525c 100644 --- a/test-suite/bugs/closed/3612.v +++ b/test-suite/bugs/closed/3612.v @@ -6,6 +6,8 @@ lines, then from 421 lines to 428 lines, then from 444 lines to 429 lines, then Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Reserved Notation "x = y :> T" (at level 70, y at next level, no associativity). Reserved Notation "x = y" (at level 70, no associativity). +Delimit Scope type_scope with type. +Bind Scope type_scope with Sortclass. Open Scope type_scope. Global Set Universe Polymorphism. Notation "A -> B" := (forall (_ : A), B) : type_scope. diff --git a/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v index 06188e7b1b..fc60897d21 100644 --- a/test-suite/bugs/closed/3649.v +++ b/test-suite/bugs/closed/3649.v @@ -4,6 +4,8 @@ coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *) Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Reserved Notation "x = y" (at level 70, no associativity). +Delimit Scope type_scope with type. +Bind Scope type_scope with Sortclass. Open Scope type_scope. Axiom admit : forall {T}, T. Notation "A -> B" := (forall (_ : A), B) : type_scope. @@ -54,4 +56,4 @@ Goal forall (C D : PreCategory) (G G' : Functor C D) (** This [change] succeeded, but did not progress, in 07e4438bd758c2ced8caf09a6961ccd77d84e42b, because [T0 x o T1 x] was not found in the goal *) let T0 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T0) end in let T1 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T1) end in - progress change (T0 x o T1 x) with ((fun y => y) (T0 x o T1 x)). \ No newline at end of file + progress change (T0 x o T1 x) with ((fun y => y) (T0 x o T1 x)). -- cgit v1.2.3 From f5e0f609c8c2c77205fcfb296535a7d8856db584 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 15 Sep 2015 15:20:47 +0200 Subject: STM: Reset takes Ltac into account (Close #4316) --- test-suite/bugs/closed/4316.v | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 test-suite/bugs/closed/4316.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4316.v b/test-suite/bugs/closed/4316.v new file mode 100644 index 0000000000..68dec1334a --- /dev/null +++ b/test-suite/bugs/closed/4316.v @@ -0,0 +1,3 @@ +Ltac tac := idtac. +Reset tac. +Ltac tac := idtac. -- cgit v1.2.3 From dffd1a75c7ecf8870935f48c8aff2a9e750be4aa Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Sep 2015 16:39:24 +0200 Subject: Test for bug #4269. --- test-suite/output/PrintAssumptions.out | 2 ++ test-suite/output/PrintAssumptions.v | 16 ++++++++++++++++ 2 files changed, 18 insertions(+) (limited to 'test-suite') diff --git a/test-suite/output/PrintAssumptions.out b/test-suite/output/PrintAssumptions.out index 23f33081b4..66458543aa 100644 --- a/test-suite/output/PrintAssumptions.out +++ b/test-suite/output/PrintAssumptions.out @@ -16,3 +16,5 @@ extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Closed under the global context Closed under the global context +Axioms: +M.foo : False diff --git a/test-suite/output/PrintAssumptions.v b/test-suite/output/PrintAssumptions.v index f23bc49808..c2003816ca 100644 --- a/test-suite/output/PrintAssumptions.v +++ b/test-suite/output/PrintAssumptions.v @@ -94,3 +94,19 @@ Proof (false_positive.add_comm 5). Print Assumptions comm_plus5. (* Should answer : Closed under the global context *) + +(** Print Assumption and Include *) + +Module INCLUDE. + +Module M. +Axiom foo : False. +End M. + +Module N. +Include M. +End N. + +Print Assumptions N.foo. + +End INCLUDE. -- cgit v1.2.3 From 16db94e6c142217a81cc78be8788137617c24de7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 16 Sep 2015 21:44:47 +0200 Subject: In pat/constr introduction patterns, fixing in a better way clearing problems of temporary hypotheses than 76f27140e6e34 did. --- test-suite/success/intros.v | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index ae1694c58c..35ba94fb67 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -61,3 +61,11 @@ Goal forall n, n = S n -> 0=0. intros n H/n_Sn. destruct H. Qed. + +(* Another check about generated names and cleared hypotheses with + pat/c patterns *) +Goal (True -> 0=0 /\ 1=1) -> True -> 0=0. +intros H (H1,?)/H. +change (1=1) in H0. +exact H1. +Qed. -- cgit v1.2.3 From bcba542aac3e17bab78f74e0fd3600e12cc0e492 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Sun, 20 Sep 2015 00:23:59 +0200 Subject: Test file for #3948 - Anomaly: unknown constant in Print Assumptions. --- test-suite/bugs/closed/3948.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 test-suite/bugs/closed/3948.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3948.v b/test-suite/bugs/closed/3948.v new file mode 100644 index 0000000000..56b1e3ffb4 --- /dev/null +++ b/test-suite/bugs/closed/3948.v @@ -0,0 +1,24 @@ +Module Type S. +Parameter t : Type. +End S. + +Module Bar(X : S). +Definition elt := X.t. +Axiom fold : elt. +End Bar. + +Module Make (Z: S) := Bar(Z). + +Declare Module Y : S. + +Module Type Interface. +Parameter constant : unit. +End Interface. + +Module DepMap : Interface. +Module Dom := Make(Y). +Definition constant : unit := + let _ := @Dom.fold in tt. +End DepMap. + +Print Assumptions DepMap.constant. -- cgit v1.2.3 From 3930c586507bfb3b80297d7a2fdbbc6049aa509b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Sep 2015 19:13:30 +0200 Subject: Updating the documentation and the toolchain w.r.t. the change in -compile. --- test-suite/Makefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'test-suite') diff --git a/test-suite/Makefile b/test-suite/Makefile index d2466250ab..39c36d5414 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -208,7 +208,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqc) "$*" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be prepared" ; \ @@ -238,7 +238,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqc) "$*" $(call get_coq_prog_args,"$<") -async-proofs on \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") -async-proofs on \ -async-proofs-private-flags fallback-to-lazy-if-marshal-error=no,fallback-to-lazy-if-slave-dies=no \ $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ @@ -352,7 +352,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v # Additionnal dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo modules/%.vo: modules/%.v - $(HIDE)$(coqtop) -R modules Mods -compile $(<:.v=) + $(HIDE)$(coqtop) -R modules Mods -compile $< ####################################################################### # Miscellaneous tests -- cgit v1.2.3 From 802f3a5c313c8ef98109a3f29c3c862de63bd53c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Sep 2015 14:17:45 +0200 Subject: Test for bug #4347. --- test-suite/bugs/closed/4347.v | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 test-suite/bugs/closed/4347.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4347.v b/test-suite/bugs/closed/4347.v new file mode 100644 index 0000000000..29686a26c1 --- /dev/null +++ b/test-suite/bugs/closed/4347.v @@ -0,0 +1,17 @@ +Fixpoint demo_recursion(n:nat) := match n with + |0 => Type + |S k => (demo_recursion k) -> Type + end. + +Record Demonstration := mkDemo +{ + demo_law : forall n:nat, demo_recursion n; + demo_stuff : forall n:nat, forall q:(fix demo_recursion (n : nat) : Type := + match n with + | 0 => Type + | S k => demo_recursion k -> Type + end) n, (demo_law (S n)) q +}. + +Theorem DemoError : Demonstration. +Fail apply mkDemo. (*Anomaly: Uncaught exception Not_found. Please report.*) -- cgit v1.2.3 From 4838a3a3c25cc9f7583dd62e4585460aca8ee961 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 21 Sep 2015 11:55:32 +0200 Subject: Forcing i > Set for global universes (incomplete) --- test-suite/bugs/closed/3309.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3309.v b/test-suite/bugs/closed/3309.v index 980431576c..6e97ed2afe 100644 --- a/test-suite/bugs/closed/3309.v +++ b/test-suite/bugs/closed/3309.v @@ -117,7 +117,7 @@ intros. hnf. apply dirprodpair. exact ax0. apply dirprodpair. exact ax1. exact a Defined. Definition eqax0 { X : UU } { R : hrel X } { A : hsubtypes X } : iseqclass R A -> ishinh ( carrier A ) . -intros X R A; exact ( fun is : iseqclass R A => projT1' _ is ). +intros X R A. exact (fun is : iseqclass R A => projT1' _ is ). Defined. Lemma iseqclassdirprod { X Y : UU } { R : hrel X } { Q : hrel Y } { A : hsubtypes X } { B : hsubtypes Y } ( isa : iseqclass R A ) ( isb : iseqclass Q B ) : iseqclass ( hreldirprod R Q ) ( subtypesdirprod A B ) . @@ -141,7 +141,7 @@ Definition prtoimage { X Y : UU } (f : X -> Y) : X -> image f. admit. Defined. -Definition setquot { X : UU } ( R : hrel X ) : Type. +Definition setquot { X : UU } ( R : hrel X ) : Set. intros; exact ( sigT' ( fun A : _ => iseqclass R A ) ). Defined. Definition setquotpair { X : UU } ( R : hrel X ) ( A : hsubtypes X ) ( is : iseqclass R A ) : setquot R. @@ -157,7 +157,7 @@ Definition setquotinset { X : UU } ( R : hrel X ) : hSet. intros; exact ( hSetpair (setquot R) admit) . Defined. -Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ). +Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot@{i j k l m n p Set q r} RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ). intros; exact ( setquotpair _ _ ( iseqclassdirprod ( projT2' _ ( projT1' _ cd ) ) ( projT2' _ ( projT2' _ cd ) ) ) ). Defined. -- cgit v1.2.3 From 91e01278de2420a64f1c8de03c0bc6e614577042 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 18:53:35 +0200 Subject: Univs: fixed bug #4328. --- test-suite/bugs/closed/4328.v | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 test-suite/bugs/closed/4328.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4328.v b/test-suite/bugs/closed/4328.v new file mode 100644 index 0000000000..8e1bb31007 --- /dev/null +++ b/test-suite/bugs/closed/4328.v @@ -0,0 +1,6 @@ +Inductive M (A:Type) : Type := M'. +Axiom pi : forall (P : Prop) (p : P), Prop. +Definition test1 A (x : _) := pi A x. (* success *) +Fail Definition test2 A (x : A) := pi A x. (* failure ??? *) +Fail Definition test3 A (x : A) (_ : M A) := pi A x. (* failure *) +Fail Definition test4 A (_ : M A) (x : A) := pi A x. (* success ??? *) \ No newline at end of file -- cgit v1.2.3 From 43858a207437fa08f066bdd3cae7bcd3034808f1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 19:14:05 +0200 Subject: Univs: fix Universe vernacular, fix bug #4287. No universe can be set lower than Prop anymore (or Set). --- test-suite/bugs/closed/4287.v | 172 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 172 insertions(+) create mode 100644 test-suite/bugs/closed/4287.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v new file mode 100644 index 0000000000..732f19f33c --- /dev/null +++ b/test-suite/bugs/closed/4287.v @@ -0,0 +1,172 @@ + +Universe b. + +Universe c. + +Definition U : Type@{b} := Type@{c}. + +Module Type MT. + +Definition T := Prop. +End MT. + +Module M : MT. + Definition T := Type@{b}. + +Print Universes. +Fail End M. + +Set Universe Polymorphism. + +(* This is a modified version of Hurkens with all universes floating *) +Section Hurkens. + +Variable down : Type -> Type. +Variable up : Type -> Type. + +Hypothesis back : forall A, up (down A) -> A. + +Hypothesis forth : forall A, A -> up (down A). + +Hypothesis backforth : forall (A:Type) (P:A->Type) (a:A), + P (back A (forth A a)) -> P a. + +Hypothesis backforth_r : forall (A:Type) (P:A->Type) (a:A), + P a -> P (back A (forth A a)). + +(** Proof *) +Definition V : Type := forall A:Type, ((up A -> Type) -> up A -> Type) -> up A -> Type. +Definition U : Type := V -> Type. + +Definition sb (z:V) : V := fun A r a => r (z A r) a. +Definition le (i:U -> Type) (x:U) : Type := x (fun A r a => i (fun v => sb v A r a)). +Definition le' (i:up (down U) -> Type) (x:up (down U)) : Type := le (fun a:U => i (forth _ a)) (back _ x). +Definition induct (i:U -> Type) : Type := forall x:U, up (le i x) -> up (i x). +Definition WF : U := fun z => down (induct (fun a => z (down U) le' (forth _ a))). +Definition I (x:U) : Type := + (forall i:U -> Type, up (le i x) -> up (i (fun v => sb v (down U) le' (forth _ x)))) -> False. + +Lemma Omega : forall i:U -> Type, induct i -> up (i WF). +Proof. +intros i y. +apply y. +unfold le, WF, induct. +apply forth. +intros x H0. +apply y. +unfold sb, le', le. +compute. +apply backforth_r. +exact H0. +Qed. + +Lemma lemma1 : induct (fun u => down (I u)). +Proof. +unfold induct. +intros x p. +apply forth. +intro q. +generalize (q (fun u => down (I u)) p). +intro r. +apply back in r. +apply r. +intros i j. +unfold le, sb, le', le in j |-. +apply backforth in j. +specialize q with (i := fun y => i (fun v:V => sb v (down U) le' (forth _ y))). +apply q. +exact j. +Qed. + +Lemma lemma2 : (forall i:U -> Type, induct i -> up (i WF)) -> False. +Proof. +intro x. +generalize (x (fun u => down (I u)) lemma1). +intro r; apply back in r. +apply r. +intros i H0. +apply (x (fun y => i (fun v => sb v (down U) le' (forth _ y)))). +unfold le, WF in H0. +apply back in H0. +exact H0. +Qed. + +Theorem paradox : False. +Proof. +exact (lemma2 Omega). +Qed. + +End Hurkens. + +Polymorphic Record box (T : Type) := wrap {unwrap : T}. + +(* Here we instantiate to Prop *) +(* Here we instantiate to Prop *) + +Fail Definition down (x : Type) : Set := box x. +Definition down (x : Set) : Set := box x. +Definition up (x : Prop) : Type := x. + +Fail Definition back A : up (down A) -> A := unwrap A. + +Fail Definition forth A : A -> up (down A) := wrap A. + +(* Lemma backforth (A:Type) (P:A->Type) (a:A) : *) +(* P (back A (forth A a)) -> P a. *) +(* Proof. *) +(* intros; assumption. *) +(* Qed. *) + +(* Lemma backforth_r (A:Type) (P:A->Type) (a:A) : *) +(* P a -> P (back A (forth A a)). *) +(* Proof. *) +(* intros; assumption. *) +(* Qed. *) + +(* Theorem bad : False. *) +(* apply (paradox down up back forth backforth backforth_r). *) +(* Qed. *) + +(* Print Assumptions bad. *) + +Definition id {A : Type} (a : A) := a. +Definition setlt (A : Type@{i}) := + let foo := Type@{i} : Type@{j} in True. + +Definition setle (B : Type@{i}) := + let foo (A : Type@{j}) := A in foo B. + +Fail Check @setlt@{j Prop}. +Check @setlt@{Prop j}. +Check @setle@{Prop j}. + +Fail Definition foo := @setle@{j Prop}. +Definition foo := @setle@{Prop j}. + +(* Definition up (x : Prop) : Type := x. *) + +(* Definition back A : up (down A) -> A := unwrap A. *) + +(* Definition forth A : A -> up (down A) := wrap A. *) + +(* Lemma backforth (A:Type) (P:A->Type) (a:A) : *) +(* P (back A (forth A a)) -> P a. *) +(* Proof. *) +(* intros; assumption. *) +(* Qed. *) + +(* Lemma backforth_r (A:Type) (P:A->Type) (a:A) : *) +(* P a -> P (back A (forth A a)). *) +(* Proof. *) +(* intros; assumption. *) +(* Qed. *) + +(* Theorem bad : False. *) +(* apply (paradox down up back forth backforth backforth_r). *) +(* Qed. *) + +(* Print Assumptions bad. *) + +(* Polymorphic Record box (T : Type) := wrap {unwrap : T}. *) + +(* Definition down (x : Type) : Prop := box x. *) -- cgit v1.2.3 From b969b459021fe70272baa85e83c12268baf13836 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Sep 2015 19:31:18 +0200 Subject: Univs: fixed bug 2584, correct universe found for mutual inductive. --- test-suite/bugs/closed/2584.v | 89 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) create mode 100644 test-suite/bugs/closed/2584.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/2584.v b/test-suite/bugs/closed/2584.v new file mode 100644 index 0000000000..a5f4ae64a0 --- /dev/null +++ b/test-suite/bugs/closed/2584.v @@ -0,0 +1,89 @@ +Require Import List. + +Set Implicit Arguments. + +Definition err : Type := unit. + +Inductive res (A: Type) : Type := +| OK: A -> res A +| Error: err -> res A. + +Implicit Arguments Error [A]. + +Set Printing Universes. + +Section FOO. + +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : ftyp -> area +. + +Print ftyp. +(* yields: +Inductive ftyp : Type (* Top.27429 *) := + Funit : ftyp | Ffun : list ftyp -> ftyp | Fref : area -> ftyp + with area : Type (* Set *) := Stored : ftyp -> area +*) + +Fixpoint tc_wf_type (ftype: ftyp) {struct ftype}: res unit := + match ftype with + | Funit => OK tt + | Ffun args => + ((fix tc_wf_types (ftypes: list ftyp){struct ftypes}: res unit := + match ftypes with + | nil => OK tt + | t::ts => + match tc_wf_type t with + | OK tt => tc_wf_types ts + | Error m => Error m + end + end) args) + | Fref a => tc_wf_area a + end +with tc_wf_area (ar:area): res unit := + match ar with + | Stored c => tc_wf_type c + end. + +End FOO. + +Print ftyp. +(* yields: +Inductive ftyp : Type (* Top.27465 *) := + Funit : ftyp | Ffun : list ftyp -> ftyp | Fref : area -> ftyp + with area : Set := Stored : ftyp -> area +*) + +Fixpoint tc_wf_type' (ftype: ftyp) {struct ftype}: res unit := + match ftype with + | Funit => OK tt + | Ffun args => + ((fix tc_wf_types (ftypes: list ftyp){struct ftypes}: res unit := + match ftypes with + | nil => OK tt + | t::ts => + match tc_wf_type' t with + | OK tt => tc_wf_types ts + | Error m => Error m + end + end) args) + | Fref a => tc_wf_area' a + end +with tc_wf_area' (ar:area): res unit := + match ar with + | Stored c => tc_wf_type' c + end. + +(* yields: +Error: +Incorrect elimination of "ar" in the inductive type "area": +the return type has sort "Type (* max(Set, Top.27424) *)" while it +should be "Prop" or "Set". +Elimination of an inductive object of sort Set +is not allowed on a predicate in sort Type +because strong elimination on non-small inductive types leads to paradoxes. +*) \ No newline at end of file -- cgit v1.2.3 From b3132ef7d45edae5b7902077aa72cc81d1d309b8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 15:22:31 +0200 Subject: Fix test-suite file --- test-suite/failure/guard-cofix.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/failure/guard-cofix.v b/test-suite/failure/guard-cofix.v index 64faa0ce0b..eda4a18673 100644 --- a/test-suite/failure/guard-cofix.v +++ b/test-suite/failure/guard-cofix.v @@ -25,7 +25,7 @@ Fail Definition ff : False := match loop with CF _ t => t end. (* Second example *) -Inductive omega := Omega : omega -> omega. +Inductive omega : Prop := Omega : omega -> omega. Lemma H : omega = CoFalse. Proof. -- cgit v1.2.3 From e51f708ac911f376f09297cad7d7d27510fe8990 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 15:30:43 +0200 Subject: Fix test-suite file: failing earlier as expected. --- test-suite/bugs/closed/3314.v | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v index e63c46da04..fb3791af55 100644 --- a/test-suite/bugs/closed/3314.v +++ b/test-suite/bugs/closed/3314.v @@ -122,12 +122,12 @@ Definition depsort (T : Type) (x : bool) : informative x := end. (** This definition should fail *) -Definition Box (T : Type1) : Prop := Lift T. +Fail Definition Box (T : Type1) : Prop := Lift T. -Definition prop {T : Type1} (t : Box T) : T := t. -Definition wrap {T : Type1} (t : T) : Box T := t. +Fail Definition prop {T : Type1} (t : Box T) : T := t. +Fail Definition wrap {T : Type1} (t : T) : Box T := t. -Definition down (x : Type1) : Prop := Box x. +Fail Definition down (x : Type1) : Prop := Box x. Definition up (x : Prop) : Type1 := x. Fail Definition back A : up (down A) -> A := @prop A. -- cgit v1.2.3 From 96760d8516398ecfa55e4e6f808dd6aa5305e483 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Sep 2015 17:57:37 +0200 Subject: Fix test-suite file for bug #3777 --- test-suite/bugs/closed/3777.v | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 test-suite/bugs/closed/3777.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3777.v b/test-suite/bugs/closed/3777.v new file mode 100644 index 0000000000..b9b2dd6b3e --- /dev/null +++ b/test-suite/bugs/closed/3777.v @@ -0,0 +1,16 @@ +Module WithoutPoly. + Unset Universe Polymorphism. + Definition foo (A : Type@{i}) (B : Type@{i}) := A -> B. + Set Printing Universes. + Definition bla := ((@foo : Set -> _ -> _) : _ -> Type -> _). + (* ((fun A : Set => foo A):Set -> Type@{Top.55} -> Type@{Top.55}) +:Set -> Type@{Top.55} -> Type@{Top.55} + : Set -> Type@{Top.55} -> Type@{Top.55} +(* |= Set <= Top.55 + *) *) +End WithoutPoly. +Module WithPoly. + Set Universe Polymorphism. + Definition foo (A : Type@{i}) (B : Type@{i}) := A -> B. + Set Printing Universes. + Fail Check ((@foo : Set -> _ -> _) : _ -> Type -> _). -- cgit v1.2.3 From 856a61c1b3c5ee2b4dec08809e5e916d8954d5f8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:13:28 +0200 Subject: Univs: test-suite file for #4301, subtyping of poly parameters --- test-suite/bugs/closed/4301.v | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 test-suite/bugs/closed/4301.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4301.v b/test-suite/bugs/closed/4301.v new file mode 100644 index 0000000000..1a8d3611bf --- /dev/null +++ b/test-suite/bugs/closed/4301.v @@ -0,0 +1,19 @@ +Set Universe Polymorphism. + +Module Type Foo. + Parameter U : Type. +End Foo. + +(* Module Lower (X : Foo). *) +(* Definition U' : Prop := X.U@{Prop}. *) +(* End Lower. *) +(* Module Lower (X : Foo with Definition U := Prop). *) +(* Definition U' := X.U@{Prop}. *) +(* End Lower. *) +Module Lower (X : Foo with Definition U := True). + (* Definition U' : Prop := X.U. *) +End Lower. + +Module M : Foo. + Definition U := nat : Type@{i}. +End M. -- cgit v1.2.3 From 816f03befa9264cd90e57c75be93f568b90ae180 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:16:19 +0200 Subject: Univs: test-suite file for bug #2016 --- test-suite/bugs/closed/2016.v | 62 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 test-suite/bugs/closed/2016.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/2016.v b/test-suite/bugs/closed/2016.v new file mode 100644 index 0000000000..13ec5bea9b --- /dev/null +++ b/test-suite/bugs/closed/2016.v @@ -0,0 +1,62 @@ +(* Coq 8.2beta4 *) +Require Import Classical_Prop. + +Record coreSemantics : Type := CoreSemantics { + core: Type; + corestep: core -> core -> Prop; + corestep_fun: forall q q1 q2, corestep q q1 -> corestep q q2 -> q1 = q2 +}. + +Definition state : Type := {sem: coreSemantics & sem.(core)}. + +Inductive step: state -> state -> Prop := + | step_core: forall sem st st' + (Hcs: sem.(corestep) st st'), + step (existT _ sem st) (existT _ sem st'). + +Lemma step_fun: forall st1 st2 st2', step st1 st2 -> step st1 st2' -> st2 = st2'. +Proof. +intros. +inversion H; clear H; subst. inversion H0; clear H0; subst; auto. +generalize (inj_pairT2 _ _ _ _ _ H2); clear H2; intro; subst. +rewrite (corestep_fun _ _ _ _ Hcs Hcs0); auto. +Qed. + +Record oe_core := oe_Core { + in_core: Type; + in_corestep: in_core -> in_core -> Prop; + in_corestep_fun: forall q q1 q2, in_corestep q q1 -> in_corestep q q2 -> q1 = q2; + in_q: in_core +}. + +Definition oe2coreSem (oec : oe_core) : coreSemantics := + CoreSemantics oec.(in_core) oec.(in_corestep) oec.(in_corestep_fun). + +Definition oe_corestep (q q': oe_core) := + step (existT _ (oe2coreSem q) q.(in_q)) (existT _ (oe2coreSem q') q'.(in_q)). + +Lemma inj_pairT1: forall (U: Type) (P: U -> Type) (p1 p2: U) x y, + existT P p1 x = existT P p2 y -> p1=p2. +Proof. intros; injection H; auto. +Qed. + +Definition f := CoreSemantics oe_core. + +Lemma oe_corestep_fun: forall q q1 q2, + oe_corestep q q1 -> oe_corestep q q2 -> q1 = q2. +Proof. +unfold oe_corestep; intros. +assert (HH:= step_fun _ _ _ H H0); clear H H0. +destruct q1; destruct q2; unfold oe2coreSem; simpl in *. +generalize (inj_pairT1 _ _ _ _ _ _ HH); clear HH; intros. +injection H; clear H; intros. +revert in_q1 in_corestep1 in_corestep_fun1 + H. +pattern in_core1. +apply eq_ind_r with (x := in_core0). +admit. +apply sym_eq. +(** good to here **) +Show Universes. +Print Universes. +Fail apply H0. \ No newline at end of file -- cgit v1.2.3 From 4b51494ef6fee2301766fb4a44020dc2ad95799f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:20:33 +0200 Subject: Univs: fix test-suite file for HoTT/coq bug #120 --- test-suite/bugs/closed/HoTT_coq_120.v | 138 ++++++++++++++++++++++++++++++++++ test-suite/bugs/opened/HoTT_coq_120.v | 137 --------------------------------- 2 files changed, 138 insertions(+), 137 deletions(-) create mode 100644 test-suite/bugs/closed/HoTT_coq_120.v delete mode 100644 test-suite/bugs/opened/HoTT_coq_120.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/HoTT_coq_120.v b/test-suite/bugs/closed/HoTT_coq_120.v new file mode 100644 index 0000000000..e46ea58bb3 --- /dev/null +++ b/test-suite/bugs/closed/HoTT_coq_120.v @@ -0,0 +1,138 @@ +Require Import TestSuite.admit. +(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines *) +Set Universe Polymorphism. +Generalizable All Variables. +Reserved Notation "g 'o' f" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. + +Class IsEquiv {A B : Type} (f : A -> B) := {}. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Fixpoint nat_to_trunc_index (n : nat) : trunc_index + := match n with + | 0 => trunc_S (trunc_S minus_two) + | S n' => trunc_S (nat_to_trunc_index n') + end. + +Coercion nat_to_trunc_index : nat >-> trunc_index. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | minus_two => Contr_internal A + | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Notation minus_one:=(trunc_S minus_two). + +Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. + +Notation Contr := (IsTrunc minus_two). +Notation IsHProp := (IsTrunc minus_one). +Notation IsHSet := (IsTrunc 0). + +Class Funext := {}. +Inductive Unit : Set := tt. + +Instance contr_unit : Contr Unit | 0 := let x := {| + center := tt; + contr := fun t : Unit => match t with tt => idpath end + |} in x. +Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. +admit. +Defined. +Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. +Definition Unit_hp:hProp:=(hp Unit _). +Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. +Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). +Definition ismono {X Y} (f : X -> Y) + := forall Z : hSet, + forall g h : Z -> X, (fun x => f (g x)) = (fun x => f (h x)) -> g = h. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := + Build_PreCategory { + object :> Type; + morphism : object -> object -> Type; + compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' + }. +Arguments compose [!C s d d'] m1 m2 : rename. + +Infix "o" := compose : morphism_scope. +Local Open Scope morphism_scope. + +Class IsEpimorphism {C} {x y} (m : morphism C x y) := + is_epimorphism : forall z (m1 m2 : morphism C y z), + m1 o m = m2 o m + -> m1 = m2. + +Class IsMonomorphism {C} {x y} (m : morphism C x y) := + is_monomorphism : forall z (m1 m2 : morphism C z x), + m o m1 = m o m2 + -> m1 = m2. +Class Univalence := {}. +Global Instance isset_hProp `{Funext} : IsHSet hProp | 0. Admitted. + +Definition set_cat : PreCategory + := @Build_PreCategory hSet + (fun x y => forall _ : x, y)%core + (fun _ _ _ f g x => f (g x))%core. +Local Inductive minus1Trunc (A :Type) : Type := min1 : A -> minus1Trunc A. +Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. Admitted. +Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). +Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, + forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h. +Definition issurj {X Y} (f:X->Y) := forall y:Y , hexists (fun x => (f x) = y). +Lemma isepi_issurj `{fs:Funext} `{ua:Univalence} `{fs' : Funext} {X Y} (f:X->Y): isepi f -> issurj f. +Proof. + intros epif y. + set (g :=fun _:Y => Unit_hp). + set (h:=(fun y:Y => (hp (hexists (fun _ : Unit => {x:X & y = (f x)})) _ ))). + clear fs'. + hnf in epif. + specialize (epif (BuildhSet hProp _) g h). + admit. +Defined. +Definition isequiv_isepi_ismono `{Univalence, fs0 : Funext} (X Y : hSet) (f : X -> Y) (epif : isepi f) (monof : ismono f) +: IsEquiv f. +Proof. + pose proof (@isepi_issurj _ _ _ _ _ f epif) as surjf. + admit. +Defined. +Section fully_faithful_helpers. + Context `{fs0 : Funext}. + Variables x y : hSet. + Variable m : x -> y. + + Fail Let isequiv_isepi_ismono_helper ua := + (@isequiv_isepi_ismono ua fs0 x y m : isepi m -> ismono m -> IsEquiv m). + + Goal True. + Fail set (isequiv_isepimorphism_ismonomorphism + := fun `{Univalence} + (Hepi : IsEpimorphism (m : morphism set_cat x y)) + (Hmono : IsMonomorphism (m : morphism set_cat x y)) + => (@isequiv_isepi_ismono_helper _ Hepi Hmono : @IsEquiv _ _ m)). + admit. + Undo. + Fail set (isequiv_isepimorphism_ismonomorphism + := fun `{Univalence} + (Hepi : IsEpimorphism (m : morphism set_cat x y)) + (Hmono : IsMonomorphism (m : morphism set_cat x y)) + => ((let _ := @isequiv_isepimorphism_ismonomorphism _ Hepi Hmono in @isequiv_isepi_ismono _ fs0 x y m Hepi Hmono) + : @IsEquiv _ _ m)). + Set Printing Universes. + admit. (* Error: Universe inconsistency (cannot enforce Top.235 <= Set because Set +< Top.235). *) diff --git a/test-suite/bugs/opened/HoTT_coq_120.v b/test-suite/bugs/opened/HoTT_coq_120.v deleted file mode 100644 index 05ee6c7b60..0000000000 --- a/test-suite/bugs/opened/HoTT_coq_120.v +++ /dev/null @@ -1,137 +0,0 @@ -Require Import TestSuite.admit. -(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines *) -Set Universe Polymorphism. -Generalizable All Variables. -Reserved Notation "g 'o' f" (at level 40, left associativity). -Inductive paths {A : Type} (a : A) : A -> Type := - idpath : paths a a. -Arguments idpath {A a} , [A] a. -Notation "x = y" := (@paths _ x y) : type_scope. - -Class IsEquiv {A B : Type} (f : A -> B) := {}. - -Class Contr_internal (A : Type) := BuildContr { - center : A ; - contr : (forall y : A, center = y) - }. - -Inductive trunc_index : Type := -| minus_two : trunc_index -| trunc_S : trunc_index -> trunc_index. - -Fixpoint nat_to_trunc_index (n : nat) : trunc_index - := match n with - | 0 => trunc_S (trunc_S minus_two) - | S n' => trunc_S (nat_to_trunc_index n') - end. - -Coercion nat_to_trunc_index : nat >-> trunc_index. - -Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := - match n with - | minus_two => Contr_internal A - | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y) - end. - -Notation minus_one:=(trunc_S minus_two). - -Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. - -Notation Contr := (IsTrunc minus_two). -Notation IsHProp := (IsTrunc minus_one). -Notation IsHSet := (IsTrunc 0). - -Class Funext := {}. -Inductive Unit : Set := tt. - -Instance contr_unit : Contr Unit | 0 := let x := {| - center := tt; - contr := fun t : Unit => match t with tt => idpath end - |} in x. -Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. -admit. -Defined. -Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}. -Definition Unit_hp:hProp:=(hp Unit _). -Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}. -Canonical Structure default_HSet:= fun T P => (@BuildhSet T P). -Definition ismono {X Y} (f : X -> Y) - := forall Z : hSet, - forall g h : Z -> X, (fun x => f (g x)) = (fun x => f (h x)) -> g = h. - -Delimit Scope morphism_scope with morphism. -Delimit Scope category_scope with category. -Delimit Scope object_scope with object. -Record PreCategory := - Build_PreCategory { - object :> Type; - morphism : object -> object -> Type; - compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' - }. -Arguments compose [!C s d d'] m1 m2 : rename. - -Infix "o" := compose : morphism_scope. -Local Open Scope morphism_scope. - -Class IsEpimorphism {C} {x y} (m : morphism C x y) := - is_epimorphism : forall z (m1 m2 : morphism C y z), - m1 o m = m2 o m - -> m1 = m2. - -Class IsMonomorphism {C} {x y} (m : morphism C x y) := - is_monomorphism : forall z (m1 m2 : morphism C z x), - m o m1 = m o m2 - -> m1 = m2. -Class Univalence := {}. -Global Instance isset_hProp `{Funext} : IsHSet hProp | 0. Admitted. - -Definition set_cat : PreCategory - := @Build_PreCategory hSet - (fun x y => forall _ : x, y)%core - (fun _ _ _ f g x => f (g x))%core. -Local Inductive minus1Trunc (A :Type) : Type := min1 : A -> minus1Trunc A. -Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. Admitted. -Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT P). -Definition isepi {X Y} `(f:X->Y) := forall Z: hSet, - forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h. -Definition issurj {X Y} (f:X->Y) := forall y:Y , hexists (fun x => (f x) = y). -Lemma isepi_issurj `{fs:Funext} `{ua:Univalence} `{fs' : Funext} {X Y} (f:X->Y): isepi f -> issurj f. -Proof. - intros epif y. - set (g :=fun _:Y => Unit_hp). - set (h:=(fun y:Y => (hp (hexists (fun _ : Unit => {x:X & y = (f x)})) _ ))). - clear fs'. - hnf in epif. - specialize (epif (BuildhSet hProp _) g h). - admit. -Defined. -Definition isequiv_isepi_ismono `{Univalence, fs0 : Funext} (X Y : hSet) (f : X -> Y) (epif : isepi f) (monof : ismono f) -: IsEquiv f. -Proof. - pose proof (@isepi_issurj _ _ _ _ _ f epif) as surjf. - admit. -Defined. -Section fully_faithful_helpers. - Context `{fs0 : Funext}. - Variables x y : hSet. - Variable m : x -> y. - - Let isequiv_isepi_ismono_helper ua := (@isequiv_isepi_ismono ua fs0 x y m : isepi m -> ismono m -> IsEquiv m). - - Goal True. - Fail set (isequiv_isepimorphism_ismonomorphism - := fun `{Univalence} - (Hepi : IsEpimorphism (m : morphism set_cat x y)) - (Hmono : IsMonomorphism (m : morphism set_cat x y)) - => (@isequiv_isepi_ismono_helper _ Hepi Hmono : @IsEquiv _ _ m)). - admit. - Undo. - Fail set (isequiv_isepimorphism_ismonomorphism' - := fun `{Univalence} - (Hepi : IsEpimorphism (m : morphism set_cat x y)) - (Hmono : IsMonomorphism (m : morphism set_cat x y)) - => ((let _ := @isequiv_isepimorphism_ismonomorphism _ Hepi Hmono in @isequiv_isepi_ismono _ fs0 x y m Hepi Hmono) - : @IsEquiv _ _ m)). - Set Printing Universes. - admit. (* Error: Universe inconsistency (cannot enforce Top.235 <= Set because Set -< Top.235). *) -- cgit v1.2.3 From 07e96102047f55be45bcb2e0a72ac3c764e398b1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 18:40:20 +0200 Subject: Univs: minor fixes to test-suite files 108 used an implicit lowering to Prop. --- test-suite/bugs/closed/HoTT_coq_053.v | 2 +- test-suite/bugs/closed/HoTT_coq_093.v | 2 +- test-suite/bugs/closed/HoTT_coq_108.v | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/HoTT_coq_053.v b/test-suite/bugs/closed/HoTT_coq_053.v index a14fb6aa57..e2bf1dbedb 100644 --- a/test-suite/bugs/closed/HoTT_coq_053.v +++ b/test-suite/bugs/closed/HoTT_coq_053.v @@ -39,7 +39,7 @@ Definition NatCategory (n : nat) := Definition NatCategory' (n : nat) := match n with | 0 => (fun X => @Build_PreCategory X - (fun _ _ => Unit : Prop)) Unit + (fun _ _ => Unit : Set)) Unit | _ => DiscreteCategory Bool end. diff --git a/test-suite/bugs/closed/HoTT_coq_093.v b/test-suite/bugs/closed/HoTT_coq_093.v index 38943ab353..f382dac976 100644 --- a/test-suite/bugs/closed/HoTT_coq_093.v +++ b/test-suite/bugs/closed/HoTT_coq_093.v @@ -21,7 +21,7 @@ Section lift. Definition Lift (A : Type@{i}) : Type@{j} := A. End lift. -Goal forall (A : Type@{i}) (x y : A), @paths@{i} A x y -> @paths@{j} A x y. +Goal forall (A : Type@{i}) (x y : A), @paths@{i j} A x y -> @paths@{j k} A x y. intros A x y p. compute in *. destruct p. exact idpath. Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_108.v b/test-suite/bugs/closed/HoTT_coq_108.v index 4f5ef99740..b6c0da76ba 100644 --- a/test-suite/bugs/closed/HoTT_coq_108.v +++ b/test-suite/bugs/closed/HoTT_coq_108.v @@ -107,7 +107,7 @@ Section path_functor. Variable D : PreCategory. Local Notation path_functor'_T F G := { HO : object_of F = object_of G - | transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) + & transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) HO (morphism_of F) = morphism_of G } -- cgit v1.2.3 From 67bdc25eb69ecd485ae1c8fa2dd71d1933f355d0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 30 Sep 2015 19:05:47 +0200 Subject: Univs: fixed 3685 by side-effect :) --- test-suite/bugs/closed/3685.v | 75 +++++++++++++++++++++++++++++++++++++++++++ test-suite/bugs/opened/3685.v | 75 ------------------------------------------- 2 files changed, 75 insertions(+), 75 deletions(-) create mode 100644 test-suite/bugs/closed/3685.v delete mode 100644 test-suite/bugs/opened/3685.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3685.v b/test-suite/bugs/closed/3685.v new file mode 100644 index 0000000000..a5bea34a98 --- /dev/null +++ b/test-suite/bugs/closed/3685.v @@ -0,0 +1,75 @@ +Require Import TestSuite.admit. +Set Universe Polymorphism. +Class Funext := { }. +Delimit Scope category_scope with category. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Set Implicit Arguments. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); + identity_of : forall s m, morphism_of s s m = morphism_of s s m }. +Definition sub_pre_cat `{Funext} (P : PreCategory -> Type) : PreCategory. +Proof. + exact (@Build_PreCategory PreCategory Functor). +Defined. +Definition opposite (C : PreCategory) : PreCategory. +Proof. + exact (@Build_PreCategory C (fun s d => morphism C d s)). +Defined. +Local Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope. +Definition prod (C D : PreCategory) : PreCategory. +Proof. + refine (@Build_PreCategory + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)). +Defined. +Local Infix "*" := prod : category_scope. +Record NaturalTransformation C D (F G : Functor C D) := {}. +Definition functor_category (C D : PreCategory) : PreCategory. +Proof. + exact (@Build_PreCategory (Functor C D) (@NaturalTransformation C D)). +Defined. +Local Notation "C -> D" := (functor_category C D) : category_scope. +Module Export PointwiseCore. + Local Open Scope category_scope. + Definition pointwise + (C C' : PreCategory) + (F : Functor C' C) + (D D' : PreCategory) + (G : Functor D D') + : Functor (C -> D) (C' -> D'). + Proof. + refine (Build_Functor + (C -> D) (C' -> D') + _ + _ + _); + abstract admit. + Defined. +End PointwiseCore. +Axiom Pidentity_of : forall (C D : PreCategory) (F : Functor C C) (G : Functor D D), pointwise F G = pointwise F G. +Local Open Scope category_scope. +Module Success. + Definition functor_uncurried `{Funext} (P : PreCategory -> Type) + (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) + : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) + := Eval cbv zeta in + let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => @Pidentity_of _ _ _ _). +End Success. +Module Bad. + Include PointwiseCore. + Definition functor_uncurried `{Funext} (P : PreCategory -> Type) + (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) + : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) + := Eval cbv zeta in + let object_of := (fun CD => (((fst CD) -> (snd CD)))) + in Build_Functor + ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) + object_of + (fun CD C'D' FG => pointwise (fst FG) (snd FG)) + (fun _ _ => @Pidentity_of _ _ _ _). diff --git a/test-suite/bugs/opened/3685.v b/test-suite/bugs/opened/3685.v deleted file mode 100644 index b2b5db6be7..0000000000 --- a/test-suite/bugs/opened/3685.v +++ /dev/null @@ -1,75 +0,0 @@ -Require Import TestSuite.admit. -Set Universe Polymorphism. -Class Funext := { }. -Delimit Scope category_scope with category. -Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. -Set Implicit Arguments. -Record Functor (C D : PreCategory) := - { object_of :> C -> D; - morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d); - identity_of : forall s m, morphism_of s s m = morphism_of s s m }. -Definition sub_pre_cat `{Funext} (P : PreCategory -> Type) : PreCategory. -Proof. - exact (@Build_PreCategory PreCategory Functor). -Defined. -Definition opposite (C : PreCategory) : PreCategory. -Proof. - exact (@Build_PreCategory C (fun s d => morphism C d s)). -Defined. -Local Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope. -Definition prod (C D : PreCategory) : PreCategory. -Proof. - refine (@Build_PreCategory - (C * D)%type - (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)). -Defined. -Local Infix "*" := prod : category_scope. -Record NaturalTransformation C D (F G : Functor C D) := {}. -Definition functor_category (C D : PreCategory) : PreCategory. -Proof. - exact (@Build_PreCategory (Functor C D) (@NaturalTransformation C D)). -Defined. -Local Notation "C -> D" := (functor_category C D) : category_scope. -Module Export PointwiseCore. - Local Open Scope category_scope. - Definition pointwise - (C C' : PreCategory) - (F : Functor C' C) - (D D' : PreCategory) - (G : Functor D D') - : Functor (C -> D) (C' -> D'). - Proof. - refine (Build_Functor - (C -> D) (C' -> D') - _ - _ - _); - abstract admit. - Defined. -End PointwiseCore. -Axiom Pidentity_of : forall (C D : PreCategory) (F : Functor C C) (G : Functor D D), pointwise F G = pointwise F G. -Local Open Scope category_scope. -Module Success. - Definition functor_uncurried `{Funext} (P : PreCategory -> Type) - (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) - : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) - := Eval cbv zeta in - let object_of := (fun CD => (((fst CD) -> (snd CD)))) - in Build_Functor - ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) - object_of - (fun CD C'D' FG => pointwise (fst FG) (snd FG)) - (fun _ _ => @Pidentity_of _ _ _ _). -End Success. -Module Bad. - Include PointwiseCore. - Fail Definition functor_uncurried `{Funext} (P : PreCategory -> Type) - (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) - : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) - := Eval cbv zeta in - let object_of := (fun CD => (((fst CD) -> (snd CD)))) - in Build_Functor - ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P) - object_of - (fun CD C'D' FG => pointwise (fst FG) (snd FG)) - (fun _ _ => @Pidentity_of _ _ _ _). -- cgit v1.2.3 From b3d97c2147418f44fc704807d3812b04921591af Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 15:36:57 +0200 Subject: Univs: fix bug #4251, handling of template polymorphic constants. --- test-suite/bugs/closed/4251.v | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 test-suite/bugs/closed/4251.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4251.v b/test-suite/bugs/closed/4251.v new file mode 100644 index 0000000000..66343d6671 --- /dev/null +++ b/test-suite/bugs/closed/4251.v @@ -0,0 +1,17 @@ + +Inductive array : Type -> Type := +| carray : forall A, array A. + +Inductive Mtac : Type -> Prop := +| bind : forall {A B}, Mtac A -> (A -> Mtac B) -> Mtac B +| array_make : forall {A}, A -> Mtac (array A). + +Definition Ref := array. + +Definition ref : forall {A}, A -> Mtac (Ref A) := + fun A x=> array_make x. +Check array Type. +Check fun A : Type => Ref A. + +Definition abs_val (a : Type) := + bind (ref a) (fun r : array Type => array_make tt). \ No newline at end of file -- cgit v1.2.3 From 90a2126b2fb2738a7684864e74e0d1ed3c861a98 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 15:41:30 +0200 Subject: Univs: the stdlib now needs 5 universes Prop < Set < i for every global univ i --- test-suite/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/Makefile b/test-suite/Makefile index 39c36d5414..31b2129001 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -388,7 +388,7 @@ misc/deps-order.log: } > "$@" # Sort universes for the whole standard library -EXPECTED_UNIVERSES := 3 +EXPECTED_UNIVERSES := 5 universes: misc/universes.log misc/universes.log: misc/universes/all_stdlib.v @echo "TEST misc/universes" -- cgit v1.2.3 From d4869e059bfb73d99e1f5ef1b0a1f0906fa27056 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 15:40:17 +0200 Subject: Univs: correct handling of with in modules For polymorphic and non-polymorphic parameters and definitions, fixes bugs #4298, #4294 --- test-suite/bugs/closed/4294.v | 31 +++++++++++++++++++++++++++++++ test-suite/bugs/closed/4298.v | 7 +++++++ 2 files changed, 38 insertions(+) create mode 100644 test-suite/bugs/closed/4294.v create mode 100644 test-suite/bugs/closed/4298.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4294.v b/test-suite/bugs/closed/4294.v new file mode 100644 index 0000000000..1d5e3c71b8 --- /dev/null +++ b/test-suite/bugs/closed/4294.v @@ -0,0 +1,31 @@ +Require Import Hurkens. + +Module NonPoly. +Module Type Foo. + Definition U := Type. + Parameter eq : Type = U. +End Foo. + +Module M : Foo with Definition U := Type. + Definition U := Type. + Definition eq : Type = U := eq_refl. +End M. + +Print Universes. +Fail Definition bad : False := TypeNeqSmallType.paradox M.U M.eq. +End NonPoly. + +Set Universe Polymorphism. + +Module Type Foo. + Definition U := Type. + Monomorphic Parameter eq : Type = U. +End Foo. + +Module M : Foo with Definition U := Type. + Definition U := Type. + Monomorphic Definition eq : Type = U := eq_refl. +End M. + +Fail Definition bad : False := TypeNeqSmallType.paradox Type M.eq. +(* Print Assumptions bad. *) diff --git a/test-suite/bugs/closed/4298.v b/test-suite/bugs/closed/4298.v new file mode 100644 index 0000000000..875612ddf4 --- /dev/null +++ b/test-suite/bugs/closed/4298.v @@ -0,0 +1,7 @@ +Set Universe Polymorphism. + +Module Type Foo. + Definition U := Type. +End Foo. + +Fail Module M : Foo with Definition U := Prop. -- cgit v1.2.3 From f4db3d72abc1872839bcacd3b28a439e69d0a2e8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 16:41:23 +0200 Subject: Univs: fix test-suite file (4301 is invalid, but a good regression test) --- test-suite/bugs/closed/4301.v | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4301.v b/test-suite/bugs/closed/4301.v index 1a8d3611bf..3b00efb213 100644 --- a/test-suite/bugs/closed/4301.v +++ b/test-suite/bugs/closed/4301.v @@ -4,14 +4,7 @@ Module Type Foo. Parameter U : Type. End Foo. -(* Module Lower (X : Foo). *) -(* Definition U' : Prop := X.U@{Prop}. *) -(* End Lower. *) -(* Module Lower (X : Foo with Definition U := Prop). *) -(* Definition U' := X.U@{Prop}. *) -(* End Lower. *) -Module Lower (X : Foo with Definition U := True). - (* Definition U' : Prop := X.U. *) +Module Lower (X : Foo with Definition U := True : Type). End Lower. Module M : Foo. -- cgit v1.2.3 From cbcf55ca44b5374f39979ced88061c82c03901b3 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 16:42:39 +0200 Subject: Univs: Remove test-suite file #3309 This relied on universes lower than Prop. A proper test for the sharing option should be found, -type-in-type is not enough either. --- test-suite/bugs/closed/3309.v | 334 ------------------------------------------ 1 file changed, 334 deletions(-) delete mode 100644 test-suite/bugs/closed/3309.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3309.v b/test-suite/bugs/closed/3309.v deleted file mode 100644 index 6e97ed2afe..0000000000 --- a/test-suite/bugs/closed/3309.v +++ /dev/null @@ -1,334 +0,0 @@ -Require Import TestSuite.admit. -(* -*- coq-prog-args: ("-emacs" "-impredicative-set") -*- *) -(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines *) -Set Universe Polymorphism. -Record sigT' {A} (P : A -> Type) := existT' { projT1' : A; projT2' : P projT1' }. -Notation "{ x : A &' P }" := (sigT' (A := A) (fun x => P)) : type_scope. -Arguments existT' {A} P _ _. -Axiom admit : forall {T}, T. -Notation paths := identity . - -Unset Automatic Introduction. - -Definition UU := Set. - -Definition dirprod ( X Y : UU ) := sigT' ( fun x : X => Y ) . -Definition dirprodpair { X Y : UU } := existT' ( fun x : X => Y ) . - -Definition ddualand { X Y P : UU } (xp : ( X -> P ) -> P ) ( yp : ( Y -> P ) -> P ) : ( dirprod X Y -> P ) -> P. -Proof. - intros X Y P xp yp X0 . - set ( int1 := fun ypp : ( ( Y -> P ) -> P ) => fun x : X => yp ( fun y : Y => X0 ( dirprodpair x y) ) ) . - apply ( xp ( int1 yp ) ) . -Defined . -Definition weq ( X Y : UU ) : UU . -intros; exact ( sigT' (fun f:X->Y => admit) ). -Defined. -Definition pr1weq ( X Y : UU):= @projT1' _ _ : weq X Y -> (X -> Y). -Coercion pr1weq : weq >-> Funclass. - -Definition invweq { X Y : UU } ( w : weq X Y ) : weq Y X . -admit. -Defined. - -Definition hProp := sigT' (fun X : Type => admit). - -Definition hProppair ( X : UU ) ( is : admit ) : hProp@{i j Set k}. -intros; exact (existT' (fun X : UU => admit ) X is ). -Defined. -Definition hProptoType := @projT1' _ _ : hProp -> Type . -Coercion hProptoType: hProp >-> Sortclass. - -Definition ishinh_UU ( X : UU ) : UU := forall P: Set, ( ( X -> P ) -> P ). - -Definition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) admit. - -Definition hinhfun { X Y : UU } ( f : X -> Y ) : ishinh_UU X -> ishinh_UU Y. -intros X Y f; exact ( fun isx : ishinh X => fun P : _ => fun yp : Y -> P => isx P ( fun x : X => yp ( f x ) ) ). -Defined. - -Definition hinhuniv { X : UU } { P : hProp } ( f : X -> P ) ( wit : ishinh_UU X ) : P. -intros; exact ( wit P f ). -Defined. - -Definition hinhand { X Y : UU } ( inx1 : ishinh_UU X ) ( iny1 : ishinh_UU Y) : ishinh ( dirprod X Y ). -intros; exact ( fun P:_ => ddualand (inx1 P) (iny1 P)) . -Defined. - -Definition UU' := Type. -Definition hSet:= sigT' (fun X : UU' => admit) . -Definition hSetpair := existT' (fun X : UU' => admit). -Definition pr1hSet:= @projT1' UU (fun X : UU' => admit) : hSet -> Type. -Coercion pr1hSet: hSet >-> Sortclass. - -Definition hPropset : hSet := existT' _ hProp admit . - -Definition hsubtypes ( X : UU ) : Type. -intros; exact (X -> hProp ). -Defined. -Definition carrier { X : UU } ( A : hsubtypes X ) : Type. -intros; exact (sigT' A). -Defined. -Coercion carrier : hsubtypes >-> Sortclass. - -Definition subtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : hsubtypes ( dirprod X Y ). -admit. -Defined. - -Lemma weqsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : weq ( subtypesdirprod A B ) ( dirprod A B ) . - admit. -Defined. - -Lemma ishinhsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( isa : ishinh A ) ( isb : ishinh B ) : ishinh ( subtypesdirprod A B ) . -Proof . - intros . - apply ( hinhfun ( invweq ( weqsubtypesdirprod A B ) ) ) . - apply hinhand . - apply isa . - apply isb . -Defined . - -Definition hrel ( X : UU ) : Type. -intros; exact ( X -> X -> hProp). -Defined. - -Definition iseqrel { X : UU } ( R : hrel X ) : Type. -admit. -Defined. - -Definition eqrel ( X : UU ) : Type. -intros; exact ( sigT' ( fun R : hrel X => iseqrel R ) ). -Defined. -Definition pr1eqrel ( X : UU ) : eqrel X -> ( X -> ( X -> hProp ) ) := @projT1' _ _ . -Coercion pr1eqrel : eqrel >-> Funclass . - -Definition hreldirprod { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) : hrel ( dirprod X Y ) . -admit. -Defined. -Set Printing Universes. -Print hProp. -Print ishinh_UU. -Print hProppair. -Definition iseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : Type. -intros; exact ( dirprod ( ishinh ( carrier A ) ) ( dirprod ( forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) )) . -Defined. -Definition iseqclassconstr { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) : iseqclass R A. -intros. hnf. apply dirprodpair. exact ax0. apply dirprodpair. exact ax1. exact ax2. -Defined. - -Definition eqax0 { X : UU } { R : hrel X } { A : hsubtypes X } : iseqclass R A -> ishinh ( carrier A ) . -intros X R A. exact (fun is : iseqclass R A => projT1' _ is ). -Defined. - -Lemma iseqclassdirprod { X Y : UU } { R : hrel X } { Q : hrel Y } { A : hsubtypes X } { B : hsubtypes Y } ( isa : iseqclass R A ) ( isb : iseqclass Q B ) : iseqclass ( hreldirprod R Q ) ( subtypesdirprod A B ) . -Proof . - intros . - set ( XY := dirprod X Y ) . - set ( AB := subtypesdirprod A B ) . - set ( RQ := hreldirprod R Q ) . - set ( ax0 := ishinhsubtypesdirprod A B ( eqax0 isa ) admit ) . - apply ( iseqclassconstr _ ax0 admit admit ) . -Defined . - -Definition image { X Y : UU } ( f : X -> Y ) : Type. -intros; exact ( sigT' ( fun y : Y => admit ) ). -Defined. -Definition pr1image { X Y : UU } ( f : X -> Y ) : image f -> Y. -intros X Y f; exact ( @projT1' _ ( fun y : Y => admit ) ). -Defined. - -Definition prtoimage { X Y : UU } (f : X -> Y) : X -> image f. - admit. -Defined. - -Definition setquot { X : UU } ( R : hrel X ) : Set. -intros; exact ( sigT' ( fun A : _ => iseqclass R A ) ). -Defined. -Definition setquotpair { X : UU } ( R : hrel X ) ( A : hsubtypes X ) ( is : iseqclass R A ) : setquot R. -intros; exact (existT' _ A is ). -Defined. -Definition pr1setquot { X : UU } ( R : hrel X ) : setquot R -> ( hsubtypes X ). -intros X R. -exact ( @projT1' _ ( fun A : _ => iseqclass R A ) ). -Defined. -Coercion pr1setquot : setquot >-> hsubtypes . - -Definition setquotinset { X : UU } ( R : hrel X ) : hSet. -intros; exact ( hSetpair (setquot R) admit) . -Defined. - -Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot@{i j k l m n p Set q r} RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ). -intros; exact ( setquotpair _ _ ( iseqclassdirprod ( projT2' _ ( projT1' _ cd ) ) ( projT2' _ ( projT2' _ cd ) ) ) ). -Defined. - -Definition iscomprelfun2 { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y ) := forall x x' x0 x0' : X , R x x' -> R x0 x0' -> paths ( f x x0 ) ( f x' x0' ) . - -Definition binop ( X : UU ) : Type. -intros; exact ( X -> X -> X ). -Defined. - -Definition setwithbinop : Type. -exact (sigT' ( fun X : hSet => binop X ) ). -Defined. -Definition pr1setwithbinop : setwithbinop -> hSet@{j k Set l}. -unfold setwithbinop. -exact ( @projT1' _ ( fun X : hSet@{j k Set l} => binop@{Set} X ) ). -Defined. -Coercion pr1setwithbinop : setwithbinop >-> hSet . - -Definition op { X : setwithbinop } : binop X. -intros; exact ( projT2' _ X ). -Defined. - -Definition subsetswithbinop { X : setwithbinop } : Type. -admit. -Defined. - -Definition carrierofasubsetwithbinop { X : setwithbinop } ( A : @subsetswithbinop X ) : setwithbinop . -admit. -Defined. - -Coercion carrierofasubsetwithbinop : subsetswithbinop >-> setwithbinop . - -Definition binopeqrel { X : setwithbinop } : Type. -intros; exact (sigT' ( fun R : eqrel X => admit ) ). -Defined. -Definition binopeqrelpair { X : setwithbinop } := existT' ( fun R : eqrel X => admit ). -Definition pr1binopeqrel ( X : setwithbinop ) : @binopeqrel X -> eqrel X. -intros X; exact ( @projT1' _ ( fun R : eqrel X => admit ) ) . -Defined. -Coercion pr1binopeqrel : binopeqrel >-> eqrel . - -Definition setwithbinopdirprod ( X Y : setwithbinop ) : setwithbinop . -admit. -Defined. - -Definition monoid : Type. -exact ( sigT' ( fun X : setwithbinop => admit ) ). -Defined. -Definition monoidpair := existT' ( fun X : setwithbinop => admit ) . -Definition pr1monoid : monoid -> setwithbinop := @projT1' _ _ . -Coercion pr1monoid : monoid >-> setwithbinop . - -Notation "x + y" := ( op x y ) : addmonoid_scope . - -Definition submonoids { X : monoid } : Type. -admit. -Defined. - -Definition submonoidstosubsetswithbinop ( X : monoid ) : @submonoids X -> @subsetswithbinop X. -admit. -Defined. -Coercion submonoidstosubsetswithbinop : submonoids >-> subsetswithbinop . - -Definition abmonoid : Type. -exact (sigT' ( fun X : setwithbinop => admit ) ). -Defined. - -Definition abmonoidtomonoid : abmonoid -> monoid. -exact (fun X : _ => monoidpair ( projT1' _ X ) admit ). -Defined. -Coercion abmonoidtomonoid : abmonoid >-> monoid . - -Definition subabmonoids { X : abmonoid } := @submonoids X . - -Definition carrierofsubabmonoid { X : abmonoid } ( A : @subabmonoids X ) : abmonoid . -Proof . - intros . - unfold subabmonoids in A . - split with A . - admit. -Defined . - -Coercion carrierofsubabmonoid : subabmonoids >-> abmonoid . - -Definition abmonoiddirprod ( X Y : abmonoid ) : abmonoid . -Proof . - intros . - split with ( setwithbinopdirprod X Y ) . - admit. -Defined . - -Open Scope addmonoid_scope . - -Definition eqrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : eqrel ( setwithbinopdirprod X A ). -admit. -Defined. - -Definition binopeqrelabmonoidfrac ( X : abmonoid ) ( A : @subabmonoids X ) : @binopeqrel ( abmonoiddirprod X A ). -intros; exact ( @binopeqrelpair ( setwithbinopdirprod X A ) ( eqrelabmonoidfrac X A ) admit ). -Defined. - -Theorem setquotuniv { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( c : setquot R ) : Y . -Proof. - intros. - apply ( pr1image ( fun x : c => f ( projT1' _ x ) ) ) . - apply ( @hinhuniv ( projT1' _ c ) ( hProppair _ admit ) ( prtoimage ( fun x : c => f ( projT1' _ x ) ) ) ) . - pose ( eqax0 ( projT2' _ c ) ) as h. - simpl in *. - Set Printing Universes. - exact h. -Defined . - -Definition setquotuniv2 { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R ) : Y . -Proof. - intros . - set ( RR := hreldirprod R R ) . - apply (setquotuniv RR Y admit). - apply dirprodtosetquot. - apply dirprodpair. - exact c. - exact c0. -Defined . - -Definition setquotfun2 { X Y : UU } ( RX : hrel X ) ( RY : eqrel Y ) ( f : X -> X -> Y ) ( cx cx0 : setquot RX ) : setquot RY . -Proof . - intros . - apply ( setquotuniv2 RX ( setquotinset RY ) admit admit admit admit ) . -Defined . - -Definition quotrel { X : UU } { R : hrel X } : hrel ( setquot R ). -intros; exact ( setquotuniv2 R hPropset admit admit ). -Defined. - -Definition setwithbinopquot { X : setwithbinop } ( R : @binopeqrel X ) : setwithbinop . -Proof . - intros . - split with ( setquotinset R ) . - set ( qtmlt := setquotfun2 R R op ) . - simpl . - unfold binop . - apply qtmlt . -Defined . - -Definition abmonoidquot { X : abmonoid } ( R : @binopeqrel X ) : abmonoid . -Proof . - intros . - split with ( setwithbinopquot R ) . - admit. -Defined . - -Definition abmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : abmonoid. -intros; exact ( @abmonoidquot (abmonoiddirprod X (@carrierofsubabmonoid X A)) ( binopeqrelabmonoidfrac X A ) ). -Defined. - -Definition abmonoidfracrel ( X : abmonoid ) ( A : @submonoids X ) : hrel (@setquot (setwithbinopdirprod X A) (eqrelabmonoidfrac X A)). -intros; exact (@quotrel _ _). -Defined. - -Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit. - -Definition ispartlbinopabmonoidfracrel_type : Type := - forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ), - @abmonoidfracrel X A ( ( admit + z ) )admit. - -Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel' : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in - ispartlbinopabmonoidfracrel_type in exact t)$. - -Unset Kernel Term Sharing. - -Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit. - -Axiom ispartlbinopabmonoidfracrel' : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in - ispartlbinopabmonoidfracrel_type in exact t)$. - -- cgit v1.2.3 From 6b9ff2261c738ff8ce47b75e5ced2b85476b6210 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 1 Oct 2015 16:46:08 +0200 Subject: Univs: fix test-suite file for #4287, now properly rejected. --- test-suite/bugs/closed/4287.v | 52 ++----------------------------------------- 1 file changed, 2 insertions(+), 50 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v index 732f19f33c..e139c5b6c9 100644 --- a/test-suite/bugs/closed/4287.v +++ b/test-suite/bugs/closed/4287.v @@ -100,35 +100,15 @@ End Hurkens. Polymorphic Record box (T : Type) := wrap {unwrap : T}. -(* Here we instantiate to Prop *) -(* Here we instantiate to Prop *) +(* Here we instantiate to Set *) -Fail Definition down (x : Type) : Set := box x. -Definition down (x : Set) : Set := box x. +Fail Definition down (x : Type) : Prop := box x. Definition up (x : Prop) : Type := x. Fail Definition back A : up (down A) -> A := unwrap A. Fail Definition forth A : A -> up (down A) := wrap A. -(* Lemma backforth (A:Type) (P:A->Type) (a:A) : *) -(* P (back A (forth A a)) -> P a. *) -(* Proof. *) -(* intros; assumption. *) -(* Qed. *) - -(* Lemma backforth_r (A:Type) (P:A->Type) (a:A) : *) -(* P a -> P (back A (forth A a)). *) -(* Proof. *) -(* intros; assumption. *) -(* Qed. *) - -(* Theorem bad : False. *) -(* apply (paradox down up back forth backforth backforth_r). *) -(* Qed. *) - -(* Print Assumptions bad. *) - Definition id {A : Type} (a : A) := a. Definition setlt (A : Type@{i}) := let foo := Type@{i} : Type@{j} in True. @@ -142,31 +122,3 @@ Check @setle@{Prop j}. Fail Definition foo := @setle@{j Prop}. Definition foo := @setle@{Prop j}. - -(* Definition up (x : Prop) : Type := x. *) - -(* Definition back A : up (down A) -> A := unwrap A. *) - -(* Definition forth A : A -> up (down A) := wrap A. *) - -(* Lemma backforth (A:Type) (P:A->Type) (a:A) : *) -(* P (back A (forth A a)) -> P a. *) -(* Proof. *) -(* intros; assumption. *) -(* Qed. *) - -(* Lemma backforth_r (A:Type) (P:A->Type) (a:A) : *) -(* P a -> P (back A (forth A a)). *) -(* Proof. *) -(* intros; assumption. *) -(* Qed. *) - -(* Theorem bad : False. *) -(* apply (paradox down up back forth backforth backforth_r). *) -(* Qed. *) - -(* Print Assumptions bad. *) - -(* Polymorphic Record box (T : Type) := wrap {unwrap : T}. *) - -(* Definition down (x : Type) : Prop := box x. *) -- cgit v1.2.3 From 07f4e6b07775052cc1c5dc34cdfa7ad4eacfa94f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 4 Oct 2015 14:50:45 +0200 Subject: Fix bug #4354: interpret hints in the right env and sigma. --- test-suite/bugs/closed/4354.v | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 test-suite/bugs/closed/4354.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4354.v b/test-suite/bugs/closed/4354.v new file mode 100644 index 0000000000..6a2f9672d3 --- /dev/null +++ b/test-suite/bugs/closed/4354.v @@ -0,0 +1,10 @@ +Inductive True : Prop := I. +Class Lift (T : Type). +Axiom closed_increment : forall {T} {H : Lift T}, True. +Create HintDb core. +Lemma closed_monotonic T (H : Lift T) : True. + auto using closed_increment. Show Universes. +Qed. + +(* also fails with -nois, so the content of the hint database does not matter +*) \ No newline at end of file -- cgit v1.2.3 From d37aab528dca587127b9f9944e1521e4fc3d9cc7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 7 Oct 2015 13:11:52 +0200 Subject: Univs: add Strict Universe Declaration option (on by default) This option disallows "declare at first use" semantics for universe variables (in @{}), forcing the declaration of _all_ universes appearing in a definition when introducing it with syntax Definition/Inductive foo@{i j k} .. The bound universes at the end of a definition/inductive must be exactly those ones, no extras allowed currently. Test-suite files using the old semantics just disable the option. --- test-suite/bugs/closed/3330.v | 1 + test-suite/bugs/closed/3352.v | 1 + test-suite/bugs/closed/3386.v | 1 + test-suite/bugs/closed/3387.v | 1 + test-suite/bugs/closed/3559.v | 1 + test-suite/bugs/closed/3566.v | 1 + test-suite/bugs/closed/3666.v | 1 + test-suite/bugs/closed/3690.v | 1 + test-suite/bugs/closed/3777.v | 1 + test-suite/bugs/closed/3779.v | 1 + test-suite/bugs/closed/3808.v | 1 + test-suite/bugs/closed/3821.v | 1 + test-suite/bugs/closed/3922.v | 1 + test-suite/bugs/closed/4089.v | 1 + test-suite/bugs/closed/4121.v | 1 + test-suite/bugs/closed/4287.v | 1 + test-suite/bugs/closed/4299.v | 12 ++++++++++++ test-suite/bugs/closed/4301.v | 1 + test-suite/bugs/closed/HoTT_coq_007.v | 1 + test-suite/bugs/closed/HoTT_coq_036.v | 1 + test-suite/bugs/closed/HoTT_coq_062.v | 1 + test-suite/bugs/closed/HoTT_coq_093.v | 1 + test-suite/bugs/opened/3754.v | 1 + test-suite/success/namedunivs.v | 2 ++ test-suite/success/polymorphism.v | 2 ++ test-suite/success/univnames.v | 26 ++++++++++++++++++++++++++ 26 files changed, 64 insertions(+) create mode 100644 test-suite/bugs/closed/4299.v create mode 100644 test-suite/success/univnames.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v index 4cd7c39e88..e6a50449da 100644 --- a/test-suite/bugs/closed/3330.v +++ b/test-suite/bugs/closed/3330.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12106 lines to 1070 lines *) Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/3352.v b/test-suite/bugs/closed/3352.v index b57b0a0f0b..f8113e4c78 100644 --- a/test-suite/bugs/closed/3352.v +++ b/test-suite/bugs/closed/3352.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* I'm not sure what the general rule should be; intuitively, I want [IsHProp (* Set *) Foo] to mean [IsHProp (* U >= Set *) Foo]. (I think this worked in HoTT/coq, too.) Morally, [IsHProp] has no universe level associated with it distinct from that of its argument, you should never get a universe inconsistency from unifying [IsHProp A] with [IsHProp A]. (The issue is tricker when IsHProp uses [A] elsewhere, as in: diff --git a/test-suite/bugs/closed/3386.v b/test-suite/bugs/closed/3386.v index 0e236c2172..b8bb8bce09 100644 --- a/test-suite/bugs/closed/3386.v +++ b/test-suite/bugs/closed/3386.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Universe Polymorphism. Set Printing Universes. Record Cat := { Obj :> Type }. diff --git a/test-suite/bugs/closed/3387.v b/test-suite/bugs/closed/3387.v index ae212caa5d..cb435e7865 100644 --- a/test-suite/bugs/closed/3387.v +++ b/test-suite/bugs/closed/3387.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Universe Polymorphism. Set Printing Universes. Record Cat := { Obj :> Type }. diff --git a/test-suite/bugs/closed/3559.v b/test-suite/bugs/closed/3559.v index 50645090fa..da12b68689 100644 --- a/test-suite/bugs/closed/3559.v +++ b/test-suite/bugs/closed/3559.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* File reduced by coq-bug-finder from original input, then from 8657 lines to 4731 lines, then from 4174 lines to 192 lines, then from 161 lines to 55 lines, then from 51 lines to 37 lines, then from 43 lines to 30 lines *) diff --git a/test-suite/bugs/closed/3566.v b/test-suite/bugs/closed/3566.v index b2aa8c3cd6..e2d7976981 100644 --- a/test-suite/bugs/closed/3566.v +++ b/test-suite/bugs/closed/3566.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Notation idmap := (fun x => x). Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. Arguments idpath {A a} , [A] a. diff --git a/test-suite/bugs/closed/3666.v b/test-suite/bugs/closed/3666.v index a5b0e9347d..e69ec10976 100644 --- a/test-suite/bugs/closed/3666.v +++ b/test-suite/bugs/closed/3666.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* File reduced by coq-bug-finder from original input, then from 11542 lines to 325 lines, then from 347 lines to 56 lines, then from 58 lines to 15 lines *) (* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *) diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v index 4069e38075..df9f5f4761 100644 --- a/test-suite/bugs/closed/3690.v +++ b/test-suite/bugs/closed/3690.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Printing Universes. Set Universe Polymorphism. Definition foo (a := Type) (b := Type) (c := Type) := Type. diff --git a/test-suite/bugs/closed/3777.v b/test-suite/bugs/closed/3777.v index b9b2dd6b3e..e203528fcc 100644 --- a/test-suite/bugs/closed/3777.v +++ b/test-suite/bugs/closed/3777.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Module WithoutPoly. Unset Universe Polymorphism. Definition foo (A : Type@{i}) (B : Type@{i}) := A -> B. diff --git a/test-suite/bugs/closed/3779.v b/test-suite/bugs/closed/3779.v index eb0d206c5c..2b44e225e8 100644 --- a/test-suite/bugs/closed/3779.v +++ b/test-suite/bugs/closed/3779.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Universe Polymorphism. Record UnitSubuniverse := { a : Type@{sm} ; x : (Type@{sm} : Type@{lg}) ; inO_internal : Type@{lg} -> Type@{lg} }. Class In (O : UnitSubuniverse@{sm lg}) (T : Type@{lg}) := in_inO_internal : inO_internal O T. diff --git a/test-suite/bugs/closed/3808.v b/test-suite/bugs/closed/3808.v index 6e19ddf8dc..a5c84e6856 100644 --- a/test-suite/bugs/closed/3808.v +++ b/test-suite/bugs/closed/3808.v @@ -1,2 +1,3 @@ +Unset Strict Universe Declaration. Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i}) := foo : Foo. \ No newline at end of file diff --git a/test-suite/bugs/closed/3821.v b/test-suite/bugs/closed/3821.v index 8da4f73626..30261ed266 100644 --- a/test-suite/bugs/closed/3821.v +++ b/test-suite/bugs/closed/3821.v @@ -1,2 +1,3 @@ +Unset Strict Universe Declaration. Inductive quotient {A : Type@{i}} {B : Type@{j}} : Type@{max(i, j)} := . diff --git a/test-suite/bugs/closed/3922.v b/test-suite/bugs/closed/3922.v index 0ccc92067d..5013bc6ac1 100644 --- a/test-suite/bugs/closed/3922.v +++ b/test-suite/bugs/closed/3922.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. Set Universe Polymorphism. Notation Type0 := Set. diff --git a/test-suite/bugs/closed/4089.v b/test-suite/bugs/closed/4089.v index c6cb9c35e6..e4d76732a3 100644 --- a/test-suite/bugs/closed/4089.v +++ b/test-suite/bugs/closed/4089.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from original input, then from 6522 lines to 318 lines, then from 1139 lines to 361 lines *) diff --git a/test-suite/bugs/closed/4121.v b/test-suite/bugs/closed/4121.v index 5f8c411ca8..d34a2b8b1b 100644 --- a/test-suite/bugs/closed/4121.v +++ b/test-suite/bugs/closed/4121.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* -*- coq-prog-args: ("-emacs" "-nois") -*- *) (* File reduced by coq-bug-finder from original input, then from 830 lines to 47 lines, then from 25 lines to 11 lines *) (* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0 diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v index e139c5b6c9..0623cf5b84 100644 --- a/test-suite/bugs/closed/4287.v +++ b/test-suite/bugs/closed/4287.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Universe b. diff --git a/test-suite/bugs/closed/4299.v b/test-suite/bugs/closed/4299.v new file mode 100644 index 0000000000..955c3017d7 --- /dev/null +++ b/test-suite/bugs/closed/4299.v @@ -0,0 +1,12 @@ +Unset Strict Universe Declaration. +Set Universe Polymorphism. + +Module Type Foo. + Definition U := Type : Type. + Parameter eq : Type = U. +End Foo. + +Module M : Foo with Definition U := Type : Type. + Definition U := let X := Type in Type. + Definition eq : Type = U := eq_refl. +Fail End M. \ No newline at end of file diff --git a/test-suite/bugs/closed/4301.v b/test-suite/bugs/closed/4301.v index 3b00efb213..b4e17c2231 100644 --- a/test-suite/bugs/closed/4301.v +++ b/test-suite/bugs/closed/4301.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Universe Polymorphism. Module Type Foo. diff --git a/test-suite/bugs/closed/HoTT_coq_007.v b/test-suite/bugs/closed/HoTT_coq_007.v index 0b8bb23534..844ff87566 100644 --- a/test-suite/bugs/closed/HoTT_coq_007.v +++ b/test-suite/bugs/closed/HoTT_coq_007.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. Module Comment1. Set Implicit Arguments. diff --git a/test-suite/bugs/closed/HoTT_coq_036.v b/test-suite/bugs/closed/HoTT_coq_036.v index 4c3e078a50..7a84531a77 100644 --- a/test-suite/bugs/closed/HoTT_coq_036.v +++ b/test-suite/bugs/closed/HoTT_coq_036.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Module Version1. Set Implicit Arguments. Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/HoTT_coq_062.v b/test-suite/bugs/closed/HoTT_coq_062.v index b7db22a69e..90d1d18306 100644 --- a/test-suite/bugs/closed/HoTT_coq_062.v +++ b/test-suite/bugs/closed/HoTT_coq_062.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from 5012 lines to 4659 lines, then from 4220 lines to 501 lines, then from 513 lines to 495 lines, then from 513 lines to 495 lines, then from 412 lines to 79 lines, then from 412 lines to 79 lines. *) diff --git a/test-suite/bugs/closed/HoTT_coq_093.v b/test-suite/bugs/closed/HoTT_coq_093.v index f382dac976..4f8868d538 100644 --- a/test-suite/bugs/closed/HoTT_coq_093.v +++ b/test-suite/bugs/closed/HoTT_coq_093.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (** It would be nice if we had more lax constraint checking of inductive types, and had variance annotations on their universes *) Set Printing All. Set Printing Implicit. diff --git a/test-suite/bugs/opened/3754.v b/test-suite/bugs/opened/3754.v index 9b3f94d917..a717bbe735 100644 --- a/test-suite/bugs/opened/3754.v +++ b/test-suite/bugs/opened/3754.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *) (* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1 diff --git a/test-suite/success/namedunivs.v b/test-suite/success/namedunivs.v index 059462fac3..f9154ef576 100644 --- a/test-suite/success/namedunivs.v +++ b/test-suite/success/namedunivs.v @@ -4,6 +4,8 @@ (* Fail exact H. *) (* Section . *) +Unset Strict Universe Declaration. + Section lift_strict. Polymorphic Definition liftlt := let t := Type@{i} : Type@{k} in diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index 957612ef1d..d6bbfe29ac 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -1,3 +1,5 @@ +Unset Strict Universe Declaration. + Module withoutpoly. Inductive empty :=. diff --git a/test-suite/success/univnames.v b/test-suite/success/univnames.v new file mode 100644 index 0000000000..31d264f645 --- /dev/null +++ b/test-suite/success/univnames.v @@ -0,0 +1,26 @@ +Set Universe Polymorphism. + +Definition foo@{i j} (A : Type@{i}) (B : Type@{j}) := A. + +Set Printing Universes. + +Fail Definition bar@{i} (A : Type@{i}) (B : Type) := A. + +Definition baz@{i j} (A : Type@{i}) (B : Type@{j}) := (A * B)%type. + +Fail Definition bad@{i j} (A : Type@{i}) (B : Type@{j}) : Type := (A * B)%type. + +Fail Definition bad@{i} (A : Type@{i}) (B : Type@{j}) : Type := (A * B)%type. + +Definition shuffle@{i j} (A : Type@{j}) (B : Type@{i}) := (A * B)%type. + +Definition nothing (A : Type) := A. + +Inductive bla@{l k} : Type@{k} := blaI : Type@{l} -> bla. + +Inductive blacopy@{k l} : Type@{k} := blacopyI : Type@{l} -> blacopy. + + +Universe g. + +Inductive blacopy'@{l} : Type@{g} := blacopy'I : Type@{l} -> blacopy'. \ No newline at end of file -- cgit v1.2.3 From 27492a7674587e1a3372cd7545e056e2775c69b3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 7 Oct 2015 14:43:49 +0200 Subject: Test for record syntax parsing. --- test-suite/success/record_syntax.v | 47 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) create mode 100644 test-suite/success/record_syntax.v (limited to 'test-suite') diff --git a/test-suite/success/record_syntax.v b/test-suite/success/record_syntax.v new file mode 100644 index 0000000000..db2bbb0dc7 --- /dev/null +++ b/test-suite/success/record_syntax.v @@ -0,0 +1,47 @@ +Module A. + +Record Foo := { foo : unit; bar : unit }. + +Definition foo_ := {| + foo := tt; + bar := tt +|}. + +Definition foo0 (p : Foo) := match p with {| |} => tt end. +Definition foo1 (p : Foo) := match p with {| foo := f |} => f end. +Definition foo2 (p : Foo) := match p with {| foo := f; |} => f end. +Definition foo3 (p : Foo) := match p with {| foo := f; bar := g |} => (f, g) end. +Definition foo4 (p : Foo) := match p with {| foo := f; bar := g; |} => (f, g) end. + +End A. + +Module B. + +Record Foo := { }. + +End B. + +Module C. + +Record Foo := { foo : unit; bar : unit; }. + +Definition foo_ := {| + foo := tt; + bar := tt; +|}. + +End C. + +Module D. + +Record Foo := { foo : unit }. +Definition foo_ := {| foo := tt |}. + +End D. + +Module E. + +Record Foo := { foo : unit; }. +Definition foo_ := {| foo := tt; |}. + +End E. -- cgit v1.2.3 From e26b4dbedd29acbfb9cbf2320193cc68afa60cf3 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 7 Oct 2015 16:51:53 +0200 Subject: Fix bug #4069: f_equal regression. --- test-suite/bugs/closed/4069.v | 51 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) create mode 100644 test-suite/bugs/closed/4069.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4069.v b/test-suite/bugs/closed/4069.v new file mode 100644 index 0000000000..21b03ce541 --- /dev/null +++ b/test-suite/bugs/closed/4069.v @@ -0,0 +1,51 @@ + +Lemma test1 : +forall (v : nat) (f g : nat -> nat), +f v = g v. +intros. f_equal. +(* +Goal in v8.5: f v = g v +Goal in v8.4: v = v -> f v = g v +Expected: f = g +*) +Admitted. + +Lemma test2 : +forall (v u : nat) (f g : nat -> nat), +f v = g u. +intros. f_equal. +(* +In both v8.4 And v8.5 +Goal 1: v = u -> f v = g u +Goal 2: v = u + +Expected Goal 1: f = g +Expected Goal 2: v = u +*) +Admitted. + +Lemma test3 : +forall (v : nat) (u : list nat) (f : nat -> nat) (g : list nat -> nat), +f v = g u. +intros. f_equal. +(* +In both v8.4 And v8.5, the goal is unchanged. +*) +Admitted. + +Require Import List. +Lemma foo n (l k : list nat) : k ++ skipn n l = skipn n l. +Proof. f_equal. +(* + 8.4: leaves the goal unchanged, i.e. k ++ skipn n l = skipn n l + 8.5: 2 goals, skipn n l = l -> k ++ skipn n l = skipn n l + and skipn n l = l +*) +Require Import List. +Fixpoint replicate {A} (n : nat) (x : A) : list A := + match n with 0 => nil | S n => x :: replicate n x end. +Lemma bar {A} n m (x : A) : + skipn n (replicate m x) = replicate (m - n) x -> + skipn n (replicate m x) = replicate (m - n) x. +Proof. intros. f_equal. +(* 8.5: one goal, n = m - n *) -- cgit v1.2.3 From 9ea8867a0fa8f2a52df102732fdc1a931c659826 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 30 Sep 2015 22:12:25 +0200 Subject: Proof using: let-in policy, optional auto-clear, forward closure* - "Proof using p*" means: use p and any section var about p. - Simplify the grammar/parser for proof using . - Section variables with a body (let-in) are pulled in automatically since they are safe to be used (add no extra quantification) - automatic clear of "unused" section variables made optional: Set Proof Using Clear Unused. since clearing section hypotheses does not "always work" (e.g. hint databases are not really cleaned) - term_typing: trigger a "suggest proof using" message also for Let theorems. --- test-suite/success/proof_using.v | 76 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v index 61e73f8587..c83f45e2a4 100644 --- a/test-suite/success/proof_using.v +++ b/test-suite/success/proof_using.v @@ -117,5 +117,81 @@ End T1. Check (bla 7 : 2 = 8). +Section A. +Variable a : nat. +Variable b : nat. +Variable c : nat. +Variable H1 : a = 3. +Variable H2 : a = 3 -> b = 7. +Variable H3 : c = 3. + +Lemma foo : a = a. +Proof using Type*. +pose H1 as e1. +pose H2 as e2. +reflexivity. +Qed. + +Lemma bar : a = 3 -> b = 7. +Proof using b*. +exact H2. +Qed. + +Lemma baz : c=3. +Proof using c*. +exact H3. +Qed. + +Lemma baz2 : c=3. +Proof using c* a. +exact H3. +Qed. + +End A. + +Check (foo 3 7 (refl_equal 3) + (fun _ => refl_equal 7)). +Check (bar 3 7 (refl_equal 3) + (fun _ => refl_equal 7)). +Check (baz2 99 3 (refl_equal 3)). +Check (baz 3 (refl_equal 3)). + +Section Let. + +Variables a b : nat. +Let pa : a = a. Proof. reflexivity. Qed. +Unset Default Proof Using. +Set Suggest Proof Using. +Lemma test_let : a = a. +Proof using a. +exact pa. +Qed. + +Let ppa : pa = pa. Proof. reflexivity. Qed. + +Lemma test_let2 : pa = pa. +Proof using Type. +exact ppa. +Qed. + +End Let. + +Check (test_let 3). + +Section Clear. + +Variable a: nat. +Hypotheses H : a = 4. + +Set Proof Using Clear Unused. + +Lemma test_clear : a = a. +Proof using a. +Fail rewrite H. +trivial. +Qed. + +End Clear. + -- cgit v1.2.3 From d6ff0fcefa21bd2c6424627049b0f5e49ed4df12 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 8 Oct 2015 14:58:11 +0200 Subject: Univs: fix bug #4161. Retypecheck abstracted infered predicate to register the right universe constraints. --- test-suite/bugs/closed/4161.v | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 test-suite/bugs/closed/4161.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4161.v b/test-suite/bugs/closed/4161.v new file mode 100644 index 0000000000..aa2b189b67 --- /dev/null +++ b/test-suite/bugs/closed/4161.v @@ -0,0 +1,27 @@ + + (* Inductive t : Type -> Type := *) + (* | Just : forall (A : Type), t A -> t A. *) + + (* Fixpoint test {A : Type} (x : t A) : t (A + unit) := *) + (* match x in t A return t (A + unit) with *) + (* | Just T x => @test T x *) + (* end. *) + + + Definition Type1 := Type. +Definition Type2 := Type. +Definition cast (x:Type2) := x:Type1. +Axiom f: Type2 -> Prop. +Definition A := + let T := fun A:Type1 => _ in + fun A':Type2 => + eq_refl : T A' = f A' :> Prop. +(* Type2 <= Type1... f A -> Type1 <= Type2 *) + +Inductive t : Type -> Type := + | Just : forall (A : Type), t A -> t A. + +Fixpoint test {A : Type} (x : t A) : t (A + unit) := + match x in t A with + | Just B x => @test B x + end. \ No newline at end of file -- cgit v1.2.3 From 5e1296a5cae4ae0ab84ddbe7b0ec71959861af97 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 9 Oct 2015 15:41:48 +0200 Subject: Refine fix for handling of the universe contexts of hints, depending on their polymorphic status _and_ locality. --- test-suite/bugs/closed/4354.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4354.v b/test-suite/bugs/closed/4354.v index 6a2f9672d3..e71ddaf71f 100644 --- a/test-suite/bugs/closed/4354.v +++ b/test-suite/bugs/closed/4354.v @@ -3,8 +3,9 @@ Class Lift (T : Type). Axiom closed_increment : forall {T} {H : Lift T}, True. Create HintDb core. Lemma closed_monotonic T (H : Lift T) : True. +Proof. + Set Printing Universes. auto using closed_increment. Show Universes. Qed. - (* also fails with -nois, so the content of the hint database does not matter *) \ No newline at end of file -- cgit v1.2.3 From ae5305a4837cce3c7fd61b92ce8110ac66ec2750 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 11 Oct 2015 15:05:10 +0200 Subject: Refining 0c320e79ba30 in fixing interpretation of constr under binders which was broken after it became possible to have binding names themselves bound to ltac variables (2fcc458af16b). Interpretation was corrected, but error message was damaged. --- test-suite/output/ltac.out | 2 ++ test-suite/output/ltac.v | 8 ++++++++ test-suite/success/ltac.v | 11 +++++++++++ 3 files changed, 21 insertions(+) create mode 100644 test-suite/output/ltac.out create mode 100644 test-suite/output/ltac.v (limited to 'test-suite') diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out new file mode 100644 index 0000000000..d003c70df9 --- /dev/null +++ b/test-suite/output/ltac.out @@ -0,0 +1,2 @@ +The command has indeed failed with message: +Error: Ltac variable y depends on pattern variable name z which is not bound in current context. diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v new file mode 100644 index 0000000000..567e21edbe --- /dev/null +++ b/test-suite/output/ltac.v @@ -0,0 +1,8 @@ +(* This used to refer to b instead of z sometimes between 8.4 and 8.5beta3 *) +Goal True. +Fail let T := constr:((fun a b : nat => a+b) 1 1) in + lazymatch T with + | (fun x z => ?y) 1 1 + => pose ((fun x _ => y) 1 1) + end. +Abort. diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index f9df021dc2..6c4d4ae98f 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -306,3 +306,14 @@ let x := ipattern:y in assert (forall x y, x = y + 0). intro. destruct y. (* Check that the name is y here *) Abort. + +(* An example suggested by Jason (see #4317) showing the intended semantics *) +(* Order of binders is reverted because y is just told to depend on x *) + +Goal 1=1. +let T := constr:(fun a b : nat => a) in + lazymatch T with + | (fun x z => ?y) => pose ((fun x x => y) 2 1) + end. +exact (eq_refl n). +Qed. -- cgit v1.2.3 From e9995f6e9f9523d4738d9ee494703b6f96bf995d Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 11 Oct 2015 14:36:29 +0200 Subject: Fixing untimely unexpected warning "Collision between bound variables" (#4317). Collecting the bound variables is now done on the glob_constr, before interpretation, so that only variables given explicitly by the user are used for binding bound variables. --- test-suite/output/ltac.v | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'test-suite') diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 567e21edbe..9a60afe5f6 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -6,3 +6,12 @@ Fail let T := constr:((fun a b : nat => a+b) 1 1) in => pose ((fun x _ => y) 1 1) end. Abort. + +(* This should not raise a warning (see #4317) *) +Goal True. +assert (H:= eq_refl ((fun x => x) 1)). +let HT := type of H in +lazymatch goal with +| H1 : HT |- _ => idtac "matched" +end. +Abort. -- cgit v1.2.3 From cd9a2e9e59d87801790859ddd26d225d71be7f7c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 11 Oct 2015 17:26:30 +0200 Subject: Fixing test-suite --- test-suite/output/ltac.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 9a60afe5f6..7e2610c7d7 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -12,6 +12,6 @@ Goal True. assert (H:= eq_refl ((fun x => x) 1)). let HT := type of H in lazymatch goal with -| H1 : HT |- _ => idtac "matched" +| H1 : HT |- _ => idtac end. Abort. -- cgit v1.2.3 From 303694c6436b36b114f4919ad7cacc9c053d11a3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 11 Oct 2015 19:06:26 +0200 Subject: Adding test for bug #4366. --- test-suite/bugs/closed/4366.v | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 test-suite/bugs/closed/4366.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4366.v b/test-suite/bugs/closed/4366.v new file mode 100644 index 0000000000..6a5e9a4023 --- /dev/null +++ b/test-suite/bugs/closed/4366.v @@ -0,0 +1,15 @@ +Fixpoint stupid (n : nat) : unit := +match n with +| 0 => tt +| S n => + let () := stupid n in + let () := stupid n in + tt +end. + +Goal True. +Proof. +pose (v := stupid 24). +Timeout 2 vm_compute in v. +exact I. +Qed. -- cgit v1.2.3 From ed95f122f3c68becc09c653471dc2982b346d343 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Tue, 13 Oct 2015 18:30:47 +0200 Subject: Fix some typos. --- test-suite/success/auto.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v index db3b19af51..aaa7b3a514 100644 --- a/test-suite/success/auto.v +++ b/test-suite/success/auto.v @@ -1,6 +1,6 @@ (* Wish #2154 by E. van der Weegen *) -(* auto was not using f_equal-style lemmas with metavariables occuring +(* auto was not using f_equal-style lemmas with metavariables occurring only in the type of an evar of the concl, but not directly in the concl itself *) -- cgit v1.2.3 From ba8dd1c47bcbbcd2678eca78783db7f5c95f37e7 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 15 Oct 2015 14:38:57 +0200 Subject: Test file for #4346: Set is no longer of type Type --- test-suite/bugs/closed/4346.v | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 test-suite/bugs/closed/4346.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4346.v b/test-suite/bugs/closed/4346.v new file mode 100644 index 0000000000..b50dff2411 --- /dev/null +++ b/test-suite/bugs/closed/4346.v @@ -0,0 +1,2 @@ +Check (Set <: Type). +Check (Set <<: Type). -- cgit v1.2.3 From 3664fd9f0af7851ed35e1fc06d826f7fd8ee2f7a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 17 Oct 2015 12:00:12 +0200 Subject: Test for bug #4325. --- test-suite/bugs/closed/4325.v | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 test-suite/bugs/closed/4325.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4325.v b/test-suite/bugs/closed/4325.v new file mode 100644 index 0000000000..af69ca04b6 --- /dev/null +++ b/test-suite/bugs/closed/4325.v @@ -0,0 +1,5 @@ +Goal (forall a b : nat, Set = (a = b)) -> Set. +Proof. + clear. + intro H. + erewrite (fun H' => H _ H'). -- cgit v1.2.3 From 8748947349a206a502e43cfe70e3397ee457c4f7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 17 Oct 2015 17:26:38 +0200 Subject: Fixing #4198 (continued): not matching within the inner lambdas/let-ins of the return clause and of the branches (what assumed that the implementation preserves the invariant that the return predicate and the branches are in canonical [fun Δ => t] form, with Δ possibly containing let-ins). --- test-suite/success/ltac.v | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 6c4d4ae98f..5bef2e512a 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -317,3 +317,29 @@ let T := constr:(fun a b : nat => a) in end. exact (eq_refl n). Qed. + +(* Check that matching "match" does not look into the invisible + canonically generated binders of the return clause and of the branches *) + +Goal forall n, match n with 0 => true | S _ => false end = true. +intros. unfold nat_rect. +Fail match goal with |- context [nat] => idtac end. +Abort. + +(* Check that branches of automatically generated elimination + principle are correctly eta-expanded and hence matchable as seen + from the user point of view *) + +Goal forall a f n, nat_rect (fun _ => nat) a f n = 0. +intros. unfold nat_rect. +match goal with |- context [f _] => idtac end. +Abort. + +(* Check that branches of automatically generated elimination + principle are in correct form also in the presence of let-ins *) + +Inductive a (b:=0) : let b':=1 in Type := c : let d:=0 in a. +Goal forall x, match x with c => 0 end = 1. +intros. +match goal with |- context [0] => idtac end. +Abort. -- cgit v1.2.3 From b3b04d0a5c7c39140e2125321a17957ddcaf2b33 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 19 Oct 2015 17:23:48 +0200 Subject: Test for #4372 (anomaly in inversion in the presence of fake dependency). --- test-suite/bugs/closed/4372.v | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 test-suite/bugs/closed/4372.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4372.v b/test-suite/bugs/closed/4372.v new file mode 100644 index 0000000000..428192a344 --- /dev/null +++ b/test-suite/bugs/closed/4372.v @@ -0,0 +1,20 @@ +(* Tactic inversion was raising an anomaly because of a fake + dependency of TypeDenote into its argument *) + +Inductive expr := +| ETrue. + +Inductive IntermediateType : Set := ITbool. + +Definition TypeDenote (IT : IntermediateType) : Type := + match IT with + | _ => bool + end. + +Inductive ValueDenote : forall (e:expr) it, TypeDenote it -> Prop := +| VT : ValueDenote ETrue ITbool true. + +Goal forall it v, @ValueDenote ETrue it v -> True. + intros it v H. + inversion H. +Abort. -- cgit v1.2.3 From de2031b8fa2a7e236d734500294ebd5050fcb7d5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 21 Oct 2015 11:56:37 +0200 Subject: Removing test for bug #3956. It breaks test-suite of trunk since Matthieu's fixes for the soundness of polymorphic universes, and I am unsure of the expected semantics. We should reintroduce it later on when we understand better the issue of simply fix it once and for all. --- test-suite/bugs/opened/3956.v | 141 ------------------------------------------ 1 file changed, 141 deletions(-) delete mode 100644 test-suite/bugs/opened/3956.v (limited to 'test-suite') diff --git a/test-suite/bugs/opened/3956.v b/test-suite/bugs/opened/3956.v deleted file mode 100644 index 94c0c6744c..0000000000 --- a/test-suite/bugs/opened/3956.v +++ /dev/null @@ -1,141 +0,0 @@ -(* -*- mode: coq; mode: visual-line -*- *) -Set Universe Polymorphism. -Set Primitive Projections. -Close Scope nat_scope. - -Record prod (A B : Type) := pair { fst : A ; snd : B }. -Arguments pair {A B} _ _. -Arguments fst {A B} _ / . -Arguments snd {A B} _ / . -Notation "x * y" := (prod x y) : type_scope. -Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. - -Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. -Definition Type2 := Eval hnf in let gt := (Type1 : Type@{i}) in Type@{i}. - -Inductive paths {A : Type} (a : A) : A -> Type := - idpath : paths a a. -Arguments idpath {A a} , [A] a. -Notation "x = y" := (@paths _ x y) : type_scope. -Definition concat {A} {x y z : A} (p : x = y) (q : y = z) : x = z - := match p, q with idpath, idpath => idpath end. - -Definition path_prod {A B : Type} (z z' : A * B) -: (fst z = fst z') -> (snd z = snd z') -> (z = z'). -Proof. - destruct z, z'; simpl; intros [] []; reflexivity. -Defined. - -Module Type TypeM. - Parameter m : Type2. -End TypeM. - -Module ProdM (XM : TypeM) (YM : TypeM) <: TypeM. - Definition m := XM.m * YM.m. -End ProdM. - -Module Type FunctionM (XM YM : TypeM). - Parameter m : XM.m -> YM.m. -End FunctionM. - -Module IdmapM (XM : TypeM) <: FunctionM XM XM. - Definition m := (fun x => x) : XM.m -> XM.m. -End IdmapM. - -Module Type HomotopyM (XM YM : TypeM) (fM gM : FunctionM XM YM). - Parameter m : forall x, fM.m x = gM.m x. -End HomotopyM. - -Module ComposeM (XM YM ZM : TypeM) - (gM : FunctionM YM ZM) (fM : FunctionM XM YM) - <: FunctionM XM ZM. - Definition m := (fun x => gM.m (fM.m x)). -End ComposeM. - -Module Type CorecM (YM ZM : TypeM) (fM : FunctionM YM ZM) - (XM : TypeM) (gM : FunctionM XM ZM). - Parameter m : XM.m -> YM.m. - Parameter m_beta : forall x, fM.m (m x) = gM.m x. -End CorecM. - -Module Type CoindpathsM (YM ZM : TypeM) (fM : FunctionM YM ZM) - (XM : TypeM) (hM kM : FunctionM XM YM). - Module fhM := ComposeM XM YM ZM fM hM. - Module fkM := ComposeM XM YM ZM fM kM. - Declare Module mM (pM : HomotopyM XM ZM fhM fkM) - : HomotopyM XM YM hM kM. -End CoindpathsM. - -Module Type Comodality (XM : TypeM). - Parameter m : Type2. - Module mM <: TypeM. - Definition m := m. - End mM. - Parameter from : m -> XM.m. - Module fromM <: FunctionM mM XM. - Definition m := from. - End fromM. - Declare Module corecM : CorecM mM XM fromM. - Declare Module coindpathsM : CoindpathsM mM XM fromM. -End Comodality. - -Module Comodality_Theory (F : Comodality). - - Module F_functor_M (XM YM : TypeM) (fM : FunctionM XM YM) - (FXM : Comodality XM) (FYM : Comodality YM). - Module f_o_from_M <: FunctionM FXM.mM YM. - Definition m := fun x => fM.m (FXM.from x). - End f_o_from_M. - Module mM := FYM.corecM FXM.mM f_o_from_M. - Definition m := mM.m. - End F_functor_M. - - Module F_prod_cmp_M (XM YM : TypeM) - (FXM : Comodality XM) (FYM : Comodality YM). - Module PM := ProdM XM YM. - Module PFM := ProdM FXM FYM. - Module fstM <: FunctionM PM XM. - Definition m := @fst XM.m YM.m. - End fstM. - Module sndM <: FunctionM PM YM. - Definition m := @snd XM.m YM.m. - End sndM. - Module FPM := F PM. - Module FfstM := F_functor_M PM XM fstM FPM FXM. - Module FsndM := F_functor_M PM YM sndM FPM FYM. - Definition m : FPM.m -> PFM.m - := fun z => (FfstM.m z , FsndM.m z). - End F_prod_cmp_M. - - Module isequiv_F_prod_cmp_M - (XM YM : TypeM) - (FXM : Comodality XM) (FYM : Comodality YM). - (** The comparison map *) - Module cmpM := F_prod_cmp_M XM YM FXM FYM. - Module FPM := cmpM.FPM. - (** We construct an inverse to it using corecursion. *) - Module prod_from_M <: FunctionM cmpM.PFM cmpM.PM. - Definition m : cmpM.PFM.m -> cmpM.PM.m - := fun z => ( FXM.from (fst z) , FYM.from (snd z) ). - End prod_from_M. - Module cmpinvM <: FunctionM cmpM.PFM FPM - := FPM.corecM cmpM.PFM prod_from_M. - (** We prove the first homotopy *) - Module cmpinv_o_cmp_M <: FunctionM FPM FPM - := ComposeM FPM cmpM.PFM FPM cmpinvM cmpM. - Module idmap_FPM <: FunctionM FPM FPM - := IdmapM FPM. - Module cip_FPM := FPM.coindpathsM FPM cmpinv_o_cmp_M idmap_FPM. - Module cip_FPHM <: HomotopyM FPM cmpM.PM cip_FPM.fhM cip_FPM.fkM. - Definition m : forall x, cip_FPM.fhM.m@{i j} x = cip_FPM.fkM.m@{i j} x. - Proof. - intros x. - refine (concat (cmpinvM.m_beta@{i j} (cmpM.m@{i j} x)) _). - apply path_prod@{i i i}; simpl. - - exact (cmpM.FfstM.mM.m_beta@{i j} x). - - exact (cmpM.FsndM.mM.m_beta@{i j} x). - Defined. - Fail End cip_FPHM. -(* End isequiv_F_prod_cmp_M. - -End Comodality_Theory.*) -- cgit v1.2.3 From 05be0a2eee49174c92f355edbdc0ffa6b44f0fac Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 21 Oct 2015 12:42:29 +0200 Subject: Bug #3956 is fixed. --- test-suite/bugs/closed/3956.v | 143 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 143 insertions(+) create mode 100644 test-suite/bugs/closed/3956.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3956.v b/test-suite/bugs/closed/3956.v new file mode 100644 index 0000000000..c19a2d4a06 --- /dev/null +++ b/test-suite/bugs/closed/3956.v @@ -0,0 +1,143 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter"); mode: visual-line -*- *) +Set Universe Polymorphism. +Set Primitive Projections. +Close Scope nat_scope. + +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Arguments pair {A B} _ _. +Arguments fst {A B} _ / . +Arguments snd {A B} _ / . +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. + +Unset Strict Universe Declaration. + +Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. +Definition Type2 := Eval hnf in let gt := (Type1 : Type@{i}) in Type@{i}. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. +Definition concat {A} {x y z : A} (p : x = y) (q : y = z) : x = z + := match p, q with idpath, idpath => idpath end. + +Definition path_prod {A B : Type} (z z' : A * B) +: (fst z = fst z') -> (snd z = snd z') -> (z = z'). +Proof. + destruct z, z'; simpl; intros [] []; reflexivity. +Defined. + +Module Type TypeM. + Parameter m : Type2. +End TypeM. + +Module ProdM (XM : TypeM) (YM : TypeM) <: TypeM. + Definition m := XM.m * YM.m. +End ProdM. + +Module Type FunctionM (XM YM : TypeM). + Parameter m : XM.m -> YM.m. +End FunctionM. + +Module IdmapM (XM : TypeM) <: FunctionM XM XM. + Definition m := (fun x => x) : XM.m -> XM.m. +End IdmapM. + +Module Type HomotopyM (XM YM : TypeM) (fM gM : FunctionM XM YM). + Parameter m : forall x, fM.m x = gM.m x. +End HomotopyM. + +Module ComposeM (XM YM ZM : TypeM) + (gM : FunctionM YM ZM) (fM : FunctionM XM YM) + <: FunctionM XM ZM. + Definition m := (fun x => gM.m (fM.m x)). +End ComposeM. + +Module Type CorecM (YM ZM : TypeM) (fM : FunctionM YM ZM) + (XM : TypeM) (gM : FunctionM XM ZM). + Parameter m : XM.m -> YM.m. + Parameter m_beta : forall x, fM.m (m x) = gM.m x. +End CorecM. + +Module Type CoindpathsM (YM ZM : TypeM) (fM : FunctionM YM ZM) + (XM : TypeM) (hM kM : FunctionM XM YM). + Module fhM := ComposeM XM YM ZM fM hM. + Module fkM := ComposeM XM YM ZM fM kM. + Declare Module mM (pM : HomotopyM XM ZM fhM fkM) + : HomotopyM XM YM hM kM. +End CoindpathsM. + +Module Type Comodality (XM : TypeM). + Parameter m : Type2. + Module mM <: TypeM. + Definition m := m. + End mM. + Parameter from : m -> XM.m. + Module fromM <: FunctionM mM XM. + Definition m := from. + End fromM. + Declare Module corecM : CorecM mM XM fromM. + Declare Module coindpathsM : CoindpathsM mM XM fromM. +End Comodality. + +Module Comodality_Theory (F : Comodality). + + Module F_functor_M (XM YM : TypeM) (fM : FunctionM XM YM) + (FXM : Comodality XM) (FYM : Comodality YM). + Module f_o_from_M <: FunctionM FXM.mM YM. + Definition m := fun x => fM.m (FXM.from x). + End f_o_from_M. + Module mM := FYM.corecM FXM.mM f_o_from_M. + Definition m := mM.m. + End F_functor_M. + + Module F_prod_cmp_M (XM YM : TypeM) + (FXM : Comodality XM) (FYM : Comodality YM). + Module PM := ProdM XM YM. + Module PFM := ProdM FXM FYM. + Module fstM <: FunctionM PM XM. + Definition m := @fst XM.m YM.m. + End fstM. + Module sndM <: FunctionM PM YM. + Definition m := @snd XM.m YM.m. + End sndM. + Module FPM := F PM. + Module FfstM := F_functor_M PM XM fstM FPM FXM. + Module FsndM := F_functor_M PM YM sndM FPM FYM. + Definition m : FPM.m -> PFM.m + := fun z => (FfstM.m z , FsndM.m z). + End F_prod_cmp_M. + + Module isequiv_F_prod_cmp_M + (XM YM : TypeM) + (FXM : Comodality XM) (FYM : Comodality YM). + (** The comparison map *) + Module cmpM := F_prod_cmp_M XM YM FXM FYM. + Module FPM := cmpM.FPM. + (** We construct an inverse to it using corecursion. *) + Module prod_from_M <: FunctionM cmpM.PFM cmpM.PM. + Definition m : cmpM.PFM.m -> cmpM.PM.m + := fun z => ( FXM.from (fst z) , FYM.from (snd z) ). + End prod_from_M. + Module cmpinvM <: FunctionM cmpM.PFM FPM + := FPM.corecM cmpM.PFM prod_from_M. + (** We prove the first homotopy *) + Module cmpinv_o_cmp_M <: FunctionM FPM FPM + := ComposeM FPM cmpM.PFM FPM cmpinvM cmpM. + Module idmap_FPM <: FunctionM FPM FPM + := IdmapM FPM. + Module cip_FPM := FPM.coindpathsM FPM cmpinv_o_cmp_M idmap_FPM. + Module cip_FPHM <: HomotopyM FPM cmpM.PM cip_FPM.fhM cip_FPM.fkM. + Definition m : forall x, cip_FPM.fhM.m@{i j} x = cip_FPM.fkM.m@{i j} x. + Proof. + intros x. + refine (concat (cmpinvM.m_beta@{i j} (cmpM.m@{i j} x)) _). + apply path_prod@{i i i}; simpl. + - exact (cmpM.FfstM.mM.m_beta@{i j} x). + - exact (cmpM.FsndM.mM.m_beta@{i j} x). + Defined. + End cip_FPHM. + End isequiv_F_prod_cmp_M. + +End Comodality_Theory. \ No newline at end of file -- cgit v1.2.3 From 273005ac85e9ae0c23328e243edeadfc8dcaf8bb Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 22 Oct 2015 22:25:35 +0200 Subject: Fixing a bug in reporting ill-formed inductive. Was introduced in b06d3badb (15 Jul 2015). --- test-suite/output/Inductive.out | 3 +++ test-suite/output/Inductive.v | 3 +++ 2 files changed, 6 insertions(+) create mode 100644 test-suite/output/Inductive.out create mode 100644 test-suite/output/Inductive.v (limited to 'test-suite') diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out new file mode 100644 index 0000000000..e912003f03 --- /dev/null +++ b/test-suite/output/Inductive.out @@ -0,0 +1,3 @@ +The command has indeed failed with message: +Last occurrence of "list'" must have "A" as 1st argument in + "A -> list' A -> list' (A * A)%type". diff --git a/test-suite/output/Inductive.v b/test-suite/output/Inductive.v new file mode 100644 index 0000000000..8db8956e32 --- /dev/null +++ b/test-suite/output/Inductive.v @@ -0,0 +1,3 @@ +Fail Inductive list' (A:Set) : Set := +| nil' : list' A +| cons' : A -> list' A -> list' (A*A). -- cgit v1.2.3 From 3df7e2a89ae931207781c6f5cbc9e196235b1dc3 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 24 Oct 2015 09:57:50 +0200 Subject: Backtracking on interpreting toplevel calls to exact in scope determined by the type to prove (was introduced in 35846ec22, r15978, Nov 2012). Not only it does not work when exact is called via a Ltac definition, but, also, it does not scale easily to refine which is a TACTIC EXTEND. Ideally, one may then want to propagate scope interpretations through ltac variables, as well as supporting refine... See #4034 for a discussion. --- test-suite/bugs/closed/4034.v | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 test-suite/bugs/closed/4034.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4034.v b/test-suite/bugs/closed/4034.v new file mode 100644 index 0000000000..3f7be4d1c7 --- /dev/null +++ b/test-suite/bugs/closed/4034.v @@ -0,0 +1,25 @@ +(* This checks compatibility of interpretation scope used for exact + between 8.4 and 8.5. See discussion at + https://coq.inria.fr/bugs/show_bug.cgi?id=4034. It is not clear + what we would like exactly, but certainly, if exact is interpreted + in a special scope, it should be interpreted consistently so also + in ltac code. *) + +Record Foo := {}. +Bind Scope foo_scope with Foo. +Notation "!" := Build_Foo : foo_scope. +Notation "!" := 1 : core_scope. +Open Scope foo_scope. +Open Scope core_scope. + +Goal Foo. + Fail exact !. +(* ... but maybe will we want it to succeed eventually if we ever + would be able to make it working the same in + +Ltac myexact e := exact e. + +Goal Foo. + myexact !. +Defined. +*) -- cgit v1.2.3 From 23803338b26bb833e9e5254d5b7ce36ce832ee59 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 26 Oct 2015 19:41:51 +0100 Subject: Two test-suite files for bugs 3974 and 3975 --- test-suite/bugs/closed/3974.v | 7 +++++++ test-suite/bugs/closed/3975.v | 8 ++++++++ 2 files changed, 15 insertions(+) create mode 100644 test-suite/bugs/closed/3974.v create mode 100644 test-suite/bugs/closed/3975.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3974.v b/test-suite/bugs/closed/3974.v new file mode 100644 index 0000000000..b6be159595 --- /dev/null +++ b/test-suite/bugs/closed/3974.v @@ -0,0 +1,7 @@ +Module Type S. +End S. + +Module Type M (X : S). + Fail Module P (X : S). + (* Used to say: Anomaly: X already exists. Please report. *) + (* Should rather say now: Error: X already exists. *) \ No newline at end of file diff --git a/test-suite/bugs/closed/3975.v b/test-suite/bugs/closed/3975.v new file mode 100644 index 0000000000..95851c8137 --- /dev/null +++ b/test-suite/bugs/closed/3975.v @@ -0,0 +1,8 @@ +Module Type S. End S. + +Module M (X:S). End M. + +Module Type P (X : S). + Print M. + (* Used to say: Anomaly: X already exists. Please report. *) + (* Should rather : print something :-) *) \ No newline at end of file -- cgit v1.2.3 From ed7af646f2e486b7e96812ba2335e644756b70fd Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 27 Oct 2015 13:55:45 -0400 Subject: Fix bugs 4389, 4390 and 4391 due to wrong handling of universe names structure. --- test-suite/bugs/closed/4390.v | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 test-suite/bugs/closed/4390.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4390.v b/test-suite/bugs/closed/4390.v new file mode 100644 index 0000000000..a96a137001 --- /dev/null +++ b/test-suite/bugs/closed/4390.v @@ -0,0 +1,37 @@ +Module A. +Set Printing All. +Set Printing Universes. + +Module M. +Section foo. +Universe i. +End foo. +End M. + +Check Type@{i}. +(* Succeeds *) + +Fail Check Type@{j}. +(* Error: Undeclared universe: j *) + +Definition foo@{j} : Type@{i} := Type@{j}. +(* ok *) +End A. + +Set Universe Polymorphism. +Fail Universes j. +Monomorphic Universe j. +Section foo. + Universes i. + Constraint i < j. + Definition foo : Type@{j} := Type@{i}. + Definition foo' : Type@{j} := Type@{i}. +End foo. + +Check eq_refl : foo@{i} = foo'@{i}. + +Definition bar := foo. +Monomorphic Definition bar'@{k} := foo@{k}. + +Fail Constraint j = j. +Monomorphic Constraint i = i. -- cgit v1.2.3 From e3ec13976d39909ac6f1a82bf1b243ba8a895190 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 28 Oct 2015 12:42:27 +0100 Subject: Revert "Fixing #4198 (continued): not matching within the inner lambdas/let-ins" After all, let's target 8.6. --- test-suite/success/ltac.v | 26 -------------------------- 1 file changed, 26 deletions(-) (limited to 'test-suite') diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 5bef2e512a..6c4d4ae98f 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -317,29 +317,3 @@ let T := constr:(fun a b : nat => a) in end. exact (eq_refl n). Qed. - -(* Check that matching "match" does not look into the invisible - canonically generated binders of the return clause and of the branches *) - -Goal forall n, match n with 0 => true | S _ => false end = true. -intros. unfold nat_rect. -Fail match goal with |- context [nat] => idtac end. -Abort. - -(* Check that branches of automatically generated elimination - principle are correctly eta-expanded and hence matchable as seen - from the user point of view *) - -Goal forall a f n, nat_rect (fun _ => nat) a f n = 0. -intros. unfold nat_rect. -match goal with |- context [f _] => idtac end. -Abort. - -(* Check that branches of automatically generated elimination - principle are in correct form also in the presence of let-ins *) - -Inductive a (b:=0) : let b':=1 in Type := c : let d:=0 in a. -Goal forall x, match x with c => 0 end = 1. -intros. -match goal with |- context [0] => idtac end. -Abort. -- cgit v1.2.3 From b5a0e384b405f64fd0854d5e88b55e8c2a159c02 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 28 Oct 2015 11:02:09 -0400 Subject: Univs: fix bug #4375, accept universe binders on (co)-fixpoints --- test-suite/bugs/closed/4375.v | 106 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 106 insertions(+) create mode 100644 test-suite/bugs/closed/4375.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4375.v b/test-suite/bugs/closed/4375.v new file mode 100644 index 0000000000..03af16535b --- /dev/null +++ b/test-suite/bugs/closed/4375.v @@ -0,0 +1,106 @@ + + +Polymorphic Fixpoint g@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t. + + +Module A. +Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => foo t n + end. +End A. + +Module B. +Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => foo t n + end. +End B. + +Module C. +Fail Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{j} (t : Type@{j}) (n : nat) : Type@{j} := + match n with + | 0 => t + | S n => foo t n + end. +End C. + +Module D. +Polymorphic Fixpoint foo@{i j} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{i j} (t : Type@{j}) (n : nat) : Type@{j} := + match n with + | 0 => t + | S n => foo t n + end. +End D. + +Module E. +Fail Polymorphic Fixpoint foo@{i j} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{j i} (t : Type@{j}) (n : nat) : Type@{j} := + match n with + | 0 => t + | S n => foo t n + end. +End E. + +(* +Polymorphic Fixpoint g@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t. + +Print g. + +Polymorphic Fixpoint a@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t +with b@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t. + +Print a. +Print b. +*) + +Polymorphic CoInductive foo@{i} (T : Type@{i}) : Type@{i} := +| A : foo T -> foo T. + +Polymorphic CoFixpoint cg@{i} (t : Type@{i}) : foo@{i} t := + @A@{i} t (cg@{i} t). + +Print cg. + +Polymorphic CoFixpoint ca@{i} (t : Type@{i}) : foo@{i} t := + @A@{i} t (@cb@{i} t) +with cb@{i} (t : Type@{i}) : foo@{i} t := + @A@{i} t (@ca@{i} t). + +Print ca. +Print cb. \ No newline at end of file -- cgit v1.2.3 From 95669265239c4da7f5cfcf134825f6801e52391f Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Wed, 21 Oct 2015 09:13:18 -0700 Subject: test cases. --- test-suite/kernel/vm-univ.v | 145 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 145 insertions(+) create mode 100644 test-suite/kernel/vm-univ.v (limited to 'test-suite') diff --git a/test-suite/kernel/vm-univ.v b/test-suite/kernel/vm-univ.v new file mode 100644 index 0000000000..1bdba3c68d --- /dev/null +++ b/test-suite/kernel/vm-univ.v @@ -0,0 +1,145 @@ +(* Basic tests *) +Polymorphic Definition pid {T : Type} (x : T) : T := x. +(* +Definition _1 : pid true = true := + @eq_refl _ true <: pid true = true. + +Polymorphic Definition a_type := Type. + +Definition _2 : a_type@{i} = Type@{i} := + @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. + +Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := + forall x : T, P x. + +Polymorphic Axiom todo : forall {T:Type}, T -> T. + +Polymorphic Definition todo' (T : Type) := @todo T. + +Definition _3 : @todo'@{Set} = @todo@{Set} := + @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. +*) + +(* Inductive Types *) +Inductive sumbool (A B : Prop) : Set := +| left : A -> sumbool A B +| right : B -> sumbool A B. + +Definition x : sumbool True False := left _ _ I. + +Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := + match H with + | left _ _ x => left _ _ x + | right _ _ x => right _ _ x + end. + +Definition _4 : sumbool_copy x = x := + @eq_refl _ x <: sumbool_copy x = x. + +(* Polymorphic Inductive Types *) +Polymorphic Inductive poption (T : Type@{i}) : Type@{i} := +| PSome : T -> poption@{i} T +| PNone : poption@{i} T. + +Polymorphic Definition poption_default {T : Type@{i}} (p : poption@{i} T) (x : T) : T := + match p with + | @PSome _ y => y + | @PNone _ => x + end. + +Polymorphic Inductive plist (T : Type@{i}) : Type@{i} := +| pnil +| pcons : T -> plist@{i} T -> plist@{i} T. + +Arguments pnil {_}. +Arguments pcons {_} _ _. + +Section pmap. + Context {T : Type@{i}} {U : Type@{j}} (f : T -> U). + + Polymorphic Fixpoint pmap (ls : plist@{i} T) : plist@{j} U := + match ls with + | @pnil _ => @pnil _ + | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) + end. +End pmap. + +Universe Ubool. +Inductive tbool : Type@{Ubool} := ttrue | tfalse. + + +Eval vm_compute in pmap pid (pcons true (pcons false pnil)). +Eval vm_compute in pmap (fun x => match x with + | pnil => true + | pcons _ _ => false + end) (pcons pnil (pcons (pcons false pnil) pnil)). +Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). + +Polymorphic Inductive Tree (T : Type@{i}) : Type@{i} := +| Empty +| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. + +Section pfold. + Context {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U). + + Polymorphic Fixpoint pfold (acc : U) (ls : plist@{i} T) : U := + match ls with + | pnil => acc + | pcons a b => pfold (f a acc) b + end. +End pfold. + +Polymorphic Inductive nat : Type@{i} := +| O +| S : nat -> nat. + +Fixpoint nat_max (a b : nat) : nat := + match a , b with + | O , b => b + | a , O => a + | S a , S b => S (nat_max a b) + end. + +Polymorphic Fixpoint height {T : Type@{i}} (t : Tree@{i} T) : nat := + match t with + | Empty _ => O + | Branch _ ls => S (pfold nat_max O (pmap height ls)) + end. + +Polymorphic Fixpoint repeat {T : Type@{i}} (n : nat) (v : T) : plist@{i} T := + match n with + | O => pnil + | S n => pcons v (repeat n v) + end. + +Polymorphic Fixpoint big_tree (n : nat) : Tree@{i} nat := + match n with + | O => @Empty nat + | S n' => Branch _ (repeat n' (big_tree n')) + end. + +Eval compute in height (big_tree (S (S (S O)))). + +Let big := S (S (S (S (S O)))). +Polymorphic Definition really_big := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). + +Time Definition _5 : height (@Empty nat) = O := + @eq_refl nat O <: height (@Empty nat) = O. + +Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := + @eq_refl nat@{Set} (S@{Set} O@{Set}) <: height@{Set} (@Branch nat pnil) = S O. + +Time Definition _7 : height (big_tree big) = big := + @eq_refl nat big <: height (big_tree big) = big. + +Time Definition _8 : height (big_tree really_big) = really_big := + @eq_refl nat@{Set} (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) + <: + @eq nat@{Set} + (@height nat@{Set} (big_tree really_big@{Set})) + really_big@{Set}. -- cgit v1.2.3 From 110f7b41eca9c3e22fff0df67419b57d9c2ef612 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 28 Oct 2015 16:56:41 +0100 Subject: Fix test suite after Matthieu's ed7af646f2e486b. --- test-suite/success/univnames.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/success/univnames.v b/test-suite/success/univnames.v index 31d264f645..048b53d26c 100644 --- a/test-suite/success/univnames.v +++ b/test-suite/success/univnames.v @@ -21,6 +21,6 @@ Inductive bla@{l k} : Type@{k} := blaI : Type@{l} -> bla. Inductive blacopy@{k l} : Type@{k} := blacopyI : Type@{l} -> blacopy. -Universe g. +Monomorphic Universe g. Inductive blacopy'@{l} : Type@{g} := blacopy'I : Type@{l} -> blacopy'. \ No newline at end of file -- cgit v1.2.3 From 654b69cbeb55a0cab3c2328d73355ad2510d1a85 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 29 Oct 2015 14:21:25 +0100 Subject: Fixing another instance of bug #3267 in eauto, this time in the presence of hints modifying the context and of a "using" clause. Incidentally opening Hints by default in debugger. --- test-suite/bugs/closed/3267.v | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3267.v b/test-suite/bugs/closed/3267.v index 5ce1ddf0c4..8175d66ac7 100644 --- a/test-suite/bugs/closed/3267.v +++ b/test-suite/bugs/closed/3267.v @@ -34,3 +34,14 @@ Module d. debug eauto. Defined. End d. + +(* An other variant which was still failing in 8.5 beta2 *) + +Parameter A B : Prop. +Axiom a:B. + +Hint Extern 1 => match goal with H:_ -> id _ |- _ => try (unfold id in H) end. +Goal (B -> id A) -> A. +intros. +eauto using a. +Abort. -- cgit v1.2.3 From a3a17b514a2ffaba54cd182fdf27b7e84366ab44 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 29 Oct 2015 15:11:29 -0400 Subject: Handle side-effects of Vernacular commands inside proofs better, so that universes are declared correctly in the enclosing proofs evar_map's. --- test-suite/success/sideff.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 test-suite/success/sideff.v (limited to 'test-suite') diff --git a/test-suite/success/sideff.v b/test-suite/success/sideff.v new file mode 100644 index 0000000000..3c0b81568a --- /dev/null +++ b/test-suite/success/sideff.v @@ -0,0 +1,12 @@ +Definition idw (A : Type) := A. +Lemma foobar : unit. +Proof. + Require Import Program. + apply (const tt tt). +Qed. + +Lemma foobar' : unit. + Lemma aux : forall A : Type, A -> unit. + Proof. intros. pose (foo := idw A). exact tt. Show Universes. Qed. + apply (@aux unit tt). +Qed. -- cgit v1.2.3 From 739d8e50b3681491bd82b516dbbba892ac5b424b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 2 Nov 2015 13:48:53 -0500 Subject: Refresh rigid universes as well, and in 8.4 compatibility mode, make them rigid to disallow minimization. --- test-suite/bugs/closed/4394.v | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 test-suite/bugs/closed/4394.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4394.v b/test-suite/bugs/closed/4394.v new file mode 100644 index 0000000000..751f1e697d --- /dev/null +++ b/test-suite/bugs/closed/4394.v @@ -0,0 +1,13 @@ +(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *) +Require Import Equality List. +Unset Strict Universe Declaration. +Inductive Foo I A := foo (B : Type) : A -> I B -> Foo I A. +Definition Family := Type -> Type. +Definition fooFamily family : Family := Foo family. +Inductive Empty {T} : T -> Prop := . +Theorem empty (family : Family) (a : fold_right prod unit (map (Foo family) nil)) (b : unit) : + Empty (a, b) -> False. +Proof. + intro e. + dependent induction e. +Qed. \ No newline at end of file -- cgit v1.2.3 From c920b420a27bd561967e316dcaca41d5e019a7b8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 2 Nov 2015 14:41:17 -0500 Subject: Fix bug #4151: discrepancy between exact and eexact/eassumption. --- test-suite/bugs/closed/4151.v | 403 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 403 insertions(+) create mode 100644 test-suite/bugs/closed/4151.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4151.v b/test-suite/bugs/closed/4151.v new file mode 100644 index 0000000000..fec64555f4 --- /dev/null +++ b/test-suite/bugs/closed/4151.v @@ -0,0 +1,403 @@ +Lemma foo (H : forall A, A) : forall A, A. + Show Universes. + eexact H. +Qed. + +(* File reduced by coq-bug-finder from original input, then from 6390 lines to 397 lines *) +(* coqc version 8.5beta1 (March 2015) compiled on Mar 17 2015 12:34:25 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (1b3759e78f227eb85a128c58b8ce8c11509dd8c3) *) +Axiom proof_admitted : False. +Tactic Notation "admit" := case proof_admitted. +Require Import Coq.Lists.SetoidList. +Require Export Coq.Program.Program. + +Global Set Implicit Arguments. +Global Set Asymmetric Patterns. + +Fixpoint combine_sig_helper {T} {P : T -> Prop} (ls : list T) : (forall x, In x ls -> P x) -> list (sig P). + admit. +Defined. + +Lemma Forall_forall1_transparent_helper_1 {A P} {x : A} {xs : list A} {l : list A} + (H : Forall P l) (H' : x::xs = l) +: P x. + admit. +Defined. +Lemma Forall_forall1_transparent_helper_2 {A P} {x : A} {xs : list A} {l : list A} + (H : Forall P l) (H' : x::xs = l) +: Forall P xs. + admit. +Defined. + +Fixpoint Forall_forall1_transparent {A} (P : A -> Prop) (l : list A) {struct l} +: Forall P l -> forall x, In x l -> P x + := match l as l return Forall P l -> forall x, In x l -> P x with + | nil => fun _ _ f => match f : False with end + | x::xs => fun H x' H' => + match H' with + | or_introl H'' => eq_rect x + P + (Forall_forall1_transparent_helper_1 H eq_refl) + _ + H'' + | or_intror H'' => @Forall_forall1_transparent A P xs (Forall_forall1_transparent_helper_2 H eq_refl) _ H'' + end + end. + +Definition combine_sig {T P ls} (H : List.Forall P ls) : list (@sig T P) + := combine_sig_helper ls (@Forall_forall1_transparent T P ls H). +Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type + := match ls with + | nil => P nil + | x::xs => (P (x::xs) * Forall_tails P xs)%type + end. + +Record string_like (CharType : Type) := + { + String :> Type; + Singleton : CharType -> String where "[ x ]" := (Singleton x); + Empty : String; + Concat : String -> String -> String where "x ++ y" := (Concat x y); + bool_eq : String -> String -> bool; + bool_eq_correct : forall x y : String, bool_eq x y = true <-> x = y; + Length : String -> nat; + Associativity : forall x y z, (x ++ y) ++ z = x ++ (y ++ z); + LeftId : forall x, Empty ++ x = x; + RightId : forall x, x ++ Empty = x; + Singleton_Length : forall x, Length (Singleton x) = 1; + Length_correct : forall s1 s2, Length s1 + Length s2 = Length (s1 ++ s2); + Length_Empty : Length Empty = 0; + Empty_Length : forall s1, Length s1 = 0 -> s1 = Empty; + Not_Singleton_Empty : forall x, Singleton x <> Empty; + SplitAt : nat -> String -> String * String; + SplitAt_correct : forall n s, fst (SplitAt n s) ++ snd (SplitAt n s) = s; + SplitAt_concat_correct : forall s1 s2, SplitAt (Length s1) (s1 ++ s2) = (s1, s2); + SplitAtLength_correct : forall n s, Length (fst (SplitAt n s)) = min (Length s) n + }. + +Delimit Scope string_like_scope with string_like. +Bind Scope string_like_scope with String. +Arguments Length {_%type_scope _} _%string_like. +Notation "[[ x ]]" := (@Singleton _ _ x) : string_like_scope. +Infix "++" := (@Concat _ _) : string_like_scope. +Infix "=s" := (@bool_eq _ _) (at level 70, right associativity) : string_like_scope. + +Definition str_le {CharType} {String : string_like CharType} (s1 s2 : String) + := Length s1 < Length s2 \/ s1 = s2. +Infix "≤s" := str_le (at level 70, right associativity). + +Record StringWithSplitState {CharType} (String : string_like CharType) (split_stateT : String -> Type) := + { string_val :> String; + state_val : split_stateT string_val }. + +Module Export ContextFreeGrammar. + Require Import Coq.Strings.String. + + Section cfg. + Variable CharType : Type. + + Section definitions. + + Inductive item := + | Terminal (_ : CharType) + | NonTerminal (_ : string). + + Definition production := list item. + Definition productions := list production. + + Record grammar := + { + Start_symbol :> string; + Lookup :> string -> productions; + Start_productions :> productions := Lookup Start_symbol; + Valid_nonterminals : list string; + Valid_productions : list productions := map Lookup Valid_nonterminals + }. + End definitions. + + End cfg. + +End ContextFreeGrammar. +Module Export BaseTypes. + Import Coq.Strings.String. + + Local Open Scope string_like_scope. + + Inductive any_grammar CharType := + | include_item (_ : item CharType) + | include_production (_ : production CharType) + | include_productions (_ : productions CharType) + | include_nonterminal (_ : string). + Global Coercion include_item : item >-> any_grammar. + Global Coercion include_production : production >-> any_grammar. + + Section recursive_descent_parser. + Context {CharType : Type} + {String : string_like CharType} + {G : grammar CharType}. + + Class parser_computational_predataT := + { nonterminals_listT : Type; + initial_nonterminals_data : nonterminals_listT; + is_valid_nonterminal : nonterminals_listT -> string -> bool; + remove_nonterminal : nonterminals_listT -> string -> nonterminals_listT; + nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop; + remove_nonterminal_dec : forall ls nonterminal, + is_valid_nonterminal ls nonterminal = true + -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; + ntl_wf : well_founded nonterminals_listT_R }. + + Class parser_computational_types_dataT := + { predata :> parser_computational_predataT; + split_stateT : String -> nonterminals_listT -> any_grammar CharType -> String -> Type }. + + Class parser_computational_dataT' `{parser_computational_types_dataT} := + { split_string_for_production + : forall (str0 : String) (valid : nonterminals_listT) (it : item CharType) (its : production CharType) (str : StringWithSplitState String (split_stateT str0 valid (it::its : production CharType))), + list (StringWithSplitState String (split_stateT str0 valid it) + * StringWithSplitState String (split_stateT str0 valid its)); + split_string_for_production_correct + : forall str0 valid it its str, + let P f := List.Forall f (@split_string_for_production str0 valid it its str) in + P (fun s1s2 => (fst s1s2 ++ snd s1s2 =s str) = true) }. + End recursive_descent_parser. + +End BaseTypes. +Import Coq.Strings.String. + +Section cfg. + Context CharType (String : string_like CharType) (G : grammar CharType). + Context (names_listT : Type) + (initial_names_data : names_listT) + (is_valid_name : names_listT -> string -> bool) + (remove_name : names_listT -> string -> names_listT) + (names_listT_R : names_listT -> names_listT -> Prop) + (remove_name_dec : forall ls name, + is_valid_name ls name = true + -> names_listT_R (remove_name ls name) ls) + (remove_name_1 + : forall ls ps ps', + is_valid_name (remove_name ls ps) ps' = true + -> is_valid_name ls ps' = true) + (remove_name_2 + : forall ls ps ps', + is_valid_name (remove_name ls ps) ps' = false + <-> is_valid_name ls ps' = false \/ ps = ps') + (ntl_wf : well_founded names_listT_R). + + Inductive minimal_parse_of + : forall (str0 : String) (valid : names_listT) + (str : String), + productions CharType -> Type := + | MinParseHead : forall str0 valid str pat pats, + @minimal_parse_of_production str0 valid str pat + -> @minimal_parse_of str0 valid str (pat::pats) + | MinParseTail : forall str0 valid str pat pats, + @minimal_parse_of str0 valid str pats + -> @minimal_parse_of str0 valid str (pat::pats) + with minimal_parse_of_production + : forall (str0 : String) (valid : names_listT) + (str : String), + production CharType -> Type := + | MinParseProductionNil : forall str0 valid, + @minimal_parse_of_production str0 valid (Empty _) nil + | MinParseProductionCons : forall str0 valid str strs pat pats, + str ++ strs ≤s str0 + -> @minimal_parse_of_item str0 valid str pat + -> @minimal_parse_of_production str0 valid strs pats + -> @minimal_parse_of_production str0 valid (str ++ strs) (pat::pats) + with minimal_parse_of_item + : forall (str0 : String) (valid : names_listT) + (str : String), + item CharType -> Type := + | MinParseTerminal : forall str0 valid x, + @minimal_parse_of_item str0 valid [[ x ]]%string_like (Terminal x) + | MinParseNonTerminal + : forall str0 valid str name, + @minimal_parse_of_name str0 valid str name + -> @minimal_parse_of_item str0 valid str (NonTerminal CharType name) + with minimal_parse_of_name + : forall (str0 : String) (valid : names_listT) + (str : String), + string -> Type := + | MinParseNonTerminalStrLt + : forall str0 valid name str, + Length str < Length str0 + -> is_valid_name initial_names_data name = true + -> @minimal_parse_of str initial_names_data str (Lookup G name) + -> @minimal_parse_of_name str0 valid str name + | MinParseNonTerminalStrEq + : forall str valid name, + is_valid_name initial_names_data name = true + -> is_valid_name valid name = true + -> @minimal_parse_of str (remove_name valid name) str (Lookup G name) + -> @minimal_parse_of_name str valid str name. +End cfg. + +Local Coercion is_true : bool >-> Sortclass. + +Local Open Scope string_like_scope. + +Section general. + Context {CharType} {String : string_like CharType} {G : grammar CharType}. + + Class boolean_parser_dataT := + { predata :> parser_computational_predataT; + split_stateT : String -> Type; + data' :> _ := {| BaseTypes.predata := predata ; BaseTypes.split_stateT := fun _ _ _ => split_stateT |}; + split_string_for_production + : forall it its, + StringWithSplitState String split_stateT + -> list (StringWithSplitState String split_stateT * StringWithSplitState String split_stateT); + split_string_for_production_correct + : forall it its (str : StringWithSplitState String split_stateT), + let P f := List.Forall f (split_string_for_production it its str) in + P (fun s1s2 => + (fst s1s2 ++ snd s1s2 =s str) = true); + premethods :> parser_computational_dataT' + := @Build_parser_computational_dataT' + _ String data' + (fun _ _ => split_string_for_production) + (fun _ _ => split_string_for_production_correct) }. + + Definition split_list_completeT `{data : boolean_parser_dataT} + {str0 valid} + (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) + (split_list : list (StringWithSplitState String split_stateT * StringWithSplitState String split_stateT)) + (it : item CharType) (its : production CharType) + := ({ s1s2 : String * String + & (fst s1s2 ++ snd s1s2 =s str) + * (minimal_parse_of_item _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (fst s1s2) it) + * (minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (snd s1s2) its) }%type) + -> ({ s1s2 : StringWithSplitState String split_stateT * StringWithSplitState String split_stateT + & (In s1s2 split_list) + * (minimal_parse_of_item _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (fst s1s2) it) + * (minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (snd s1s2) its) }%type). +End general. + +Section recursive_descent_parser. + Context {CharType} + {String : string_like CharType} + {G : grammar CharType}. + Context `{data : @boolean_parser_dataT _ String}. + + Section bool. + Section parts. + Definition parse_item + (str_matches_nonterminal : string -> bool) + (str : StringWithSplitState String split_stateT) + (it : item CharType) + : bool + := match it with + | Terminal ch => [[ ch ]] =s str + | NonTerminal nt => str_matches_nonterminal nt + end. + + Section production. + Context {str0} + (parse_nonterminal + : forall (str : StringWithSplitState String split_stateT), + str ≤s str0 + -> string + -> bool). + + Fixpoint parse_production + (str : StringWithSplitState String split_stateT) + (pf : str ≤s str0) + (prod : production CharType) + : bool. + Proof. + refine + match prod with + | nil => + + str =s Empty _ + | it::its + => let parse_production' := fun str pf => parse_production str pf its in + fold_right + orb + false + (let mapF f := map f (combine_sig (split_string_for_production_correct it its str)) in + mapF (fun s1s2p => + (parse_item + (parse_nonterminal (fst (proj1_sig s1s2p)) _) + (fst (proj1_sig s1s2p)) + it) + && parse_production' (snd (proj1_sig s1s2p)) _)%bool) + end; + revert pf; clear; intros; admit. + Defined. + End production. + + End parts. + End bool. +End recursive_descent_parser. + +Section sound. + Context CharType (String : string_like CharType) (G : grammar CharType). + Context `{data : @boolean_parser_dataT CharType String}. + + Section production. + Context (str0 : String) + (parse_nonterminal : forall (str : StringWithSplitState String split_stateT), + str ≤s str0 + -> string + -> bool). + + Definition parse_nonterminal_completeT P + := forall valid (str : StringWithSplitState String split_stateT) pf nonterminal (H_sub : P str0 valid nonterminal), + minimal_parse_of_name _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str nonterminal + -> @parse_nonterminal str pf nonterminal = true. + + Lemma parse_production_complete + valid Pv + (parse_nonterminal_complete : parse_nonterminal_completeT Pv) + (Hinit : forall str (pf : str ≤s str0) nonterminal, + minimal_parse_of_name String G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str nonterminal + -> Pv str0 valid nonterminal) + (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) + (prod : production CharType) + (split_string_for_production_complete' + : forall str0 valid str pf, + Forall_tails + (fun prod' => + match prod' return Type with + | nil => True + | it::its => split_list_completeT (G := G) (valid := valid) (str0 := str0) str pf (split_string_for_production it its str) it its + end) + prod) + : minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str prod + -> parse_production parse_nonterminal str pf prod = true. + admit. + Defined. + End production. + Context (str0 : String) + (parse_nonterminal : forall (str : StringWithSplitState String split_stateT), + str ≤s str0 + -> string + -> bool). + + Goal forall (a : production CharType), + (forall (str1 : String) (valid : nonterminals_listT) + (str : StringWithSplitState String split_stateT) + (pf : str ≤s str1), + Forall_tails + (fun prod' : list (item CharType) => + match prod' with + | [] => True + | it :: its => + split_list_completeT (G := G) (valid := valid) str pf + (split_string_for_production it its str) it its + end) a) -> + forall (str : String) (pf : str ≤s str0) (st : split_stateT str), + parse_production parse_nonterminal + {| string_val := str; state_val := st |} pf a = true. + Proof. + intros a X **. + eapply parse_production_complete. + Focus 3. + exact X. + Undo. + assumption. + Undo. + eassumption. (* no applicable tactic *) \ No newline at end of file -- cgit v1.2.3 From f4ff8f4f8b0bd2c721e4984faf7360d6fab93b05 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 4 Nov 2015 09:44:56 +0100 Subject: Test file for #4397. --- test-suite/bugs/closed/4397.v | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 test-suite/bugs/closed/4397.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4397.v b/test-suite/bugs/closed/4397.v new file mode 100644 index 0000000000..3566353d84 --- /dev/null +++ b/test-suite/bugs/closed/4397.v @@ -0,0 +1,3 @@ +Require Import Equality. +Theorem foo (u : unit) (H : u = u) : True. +dependent destruction H. -- cgit v1.2.3 From b30ca8ac9e0225e6505fea0004ea37e7649c9cb6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 3 Nov 2015 17:25:49 -0500 Subject: Fix bug in proofs/logic.ml type_of_global_reference_knowing_conclusion is buggy in general. --- test-suite/bugs/closed/4394.v | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4394.v b/test-suite/bugs/closed/4394.v index 751f1e697d..60c9354597 100644 --- a/test-suite/bugs/closed/4394.v +++ b/test-suite/bugs/closed/4394.v @@ -1,13 +1,19 @@ (* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *) + Require Import Equality List. -Unset Strict Universe Declaration. -Inductive Foo I A := foo (B : Type) : A -> I B -> Foo I A. +Inductive Foo (I : Type -> Type) (A : Type) : Type := +| foo (B : Type) : A -> I B -> Foo I A. Definition Family := Type -> Type. -Definition fooFamily family : Family := Foo family. +Definition FooToo : Family -> Family := Foo. +Definition optionize (I : Type -> Type) (A : Type) := option (I A). +Definition bar (I : Type -> Type) (A : Type) : A -> option (I A) -> Foo (optionize I) A := foo (optionize I) A A. +Record Rec (I : Type -> Type) := { rec : forall A : Type, A -> I A -> Foo I A }. +Definition barRec : Rec (optionize id) := {| rec := bar id |}. Inductive Empty {T} : T -> Prop := . Theorem empty (family : Family) (a : fold_right prod unit (map (Foo family) nil)) (b : unit) : Empty (a, b) -> False. Proof. intro e. dependent induction e. -Qed. \ No newline at end of file +Qed. + -- cgit v1.2.3 From acc54398bd244b15d4dbc396836c279eabf3bf6b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 4 Nov 2015 13:37:10 -0500 Subject: Hint Cut documentation and cleanup of printing (was duplicated and inconsistent). --- test-suite/success/Hints.v | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v index cc8cec4707..f934a5c74a 100644 --- a/test-suite/success/Hints.v +++ b/test-suite/success/Hints.v @@ -62,3 +62,47 @@ Axiom cast_coalesce : ((e :? pf1) :? pf2) = (e :? trans_eq pf1 pf2). Hint Rewrite cast_coalesce : ltamer. + +Require Import Program. +Module HintCut. +Class A (f : nat -> nat) := a : True. +Class B (f : nat -> nat) := b : True. +Class C (f : nat -> nat) := c : True. +Class D (f : nat -> nat) := d : True. +Class E (f : nat -> nat) := e : True. + +Instance a_is_b f : A f -> B f. +Proof. easy. Qed. +Instance b_is_c f : B f -> C f. +Proof. easy. Qed. +Instance c_is_d f : C f -> D f. +Proof. easy. Qed. +Instance d_is_e f : D f -> E f. +Proof. easy. Qed. + +Instance a_compose f g : A f -> A g -> A (compose f g). +Proof. easy. Qed. +Instance b_compose f g : B f -> B g -> B (compose f g). +Proof. easy. Qed. +Instance c_compose f g : C f -> C g -> C (compose f g). +Proof. easy. Qed. +Instance d_compose f g : D f -> D g -> D (compose f g). +Proof. easy. Qed. +Instance e_compose f g : E f -> E g -> E (compose f g). +Proof. easy. Qed. + +Instance a_id : A id. +Proof. easy. Qed. + +Instance foo f : + E (id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ + id ∘ id ∘ id ∘ id ∘ id ∘ f ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id). +Proof. + Fail Timeout 1 apply _. (* 3.7s *) + +Hint Cut [!*; (a_is_b | b_is_c | c_is_d | d_is_e) ; + (a_compose | b_compose | c_compose | d_compose | e_compose)] : typeclass_instances. + + Timeout 1 Fail apply _. (* 0.06s *) +Abort. +End HintCut. \ No newline at end of file -- cgit v1.2.3 From 7c102bb3a3798a234701fdc28a8e8ec28ee2549c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 4 Nov 2015 18:09:02 -0500 Subject: Univs: missing checks in evarsolve with candidates and missing a whd_evar in refresh_universes. --- test-suite/bugs/closed/HoTT_coq_014.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v index ae3e50d7ee..223a98de1c 100644 --- a/test-suite/bugs/closed/HoTT_coq_014.v +++ b/test-suite/bugs/closed/HoTT_coq_014.v @@ -3,9 +3,9 @@ Set Implicit Arguments. Generalizable All Variables. Set Universe Polymorphism. -Polymorphic Record SpecializedCategory (obj : Type) := Build_SpecializedCategory' { - Object :> _ := obj; - Morphism' : obj -> obj -> Type; +Polymorphic Record SpecializedCategory@{l k} (obj : Type@{l}) := Build_SpecializedCategory' { + Object :> Type@{l} := obj; + Morphism' : obj -> obj -> Type@{k}; Identity' : forall o, Morphism' o o; Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d' -- cgit v1.2.3 From ce6392e74fbe0edd5ebcaecb362fec5da9b4703b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 15:10:29 -0500 Subject: Add test-suite file for #4273. --- test-suite/bugs/closed/4273.v | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 test-suite/bugs/closed/4273.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4273.v b/test-suite/bugs/closed/4273.v new file mode 100644 index 0000000000..591ea4b5b2 --- /dev/null +++ b/test-suite/bugs/closed/4273.v @@ -0,0 +1,9 @@ + + +Set Primitive Projections. +Record total2 (P : nat -> Prop) := tpair { pr1 : nat; pr2 : P pr1 }. +Theorem onefiber' (q : total2 (fun y => y = 0)) : True. +Proof. assert (foo:=pr2 _ q). simpl in foo. + destruct foo. (* Error: q is used in conclusion. *) exact I. Qed. + +Print onefiber'. \ No newline at end of file -- cgit v1.2.3 From 6b3d6f9326de9e53805d14e78577411c7174a998 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 6 Nov 2015 14:00:41 +0100 Subject: Fixing complexity issue with f_equal. Thanks to J.-H. Jourdan for reporting it. A "cut" was not appropriately chained on the second goal but on both goals, with the chaining on the first goal introducing noise. --- test-suite/complexity/f_equal.v | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 test-suite/complexity/f_equal.v (limited to 'test-suite') diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v new file mode 100644 index 0000000000..30e87939ec --- /dev/null +++ b/test-suite/complexity/f_equal.v @@ -0,0 +1,14 @@ +(* Checks that f_equal does not reduce the term uselessly *) +(* Expected time < 1.00s *) + +Fixpoint stupid (n : nat) : unit := +match n with +| 0 => tt +| S n => + let () := stupid n in + let () := stupid n in + tt +end. + +Goal stupid 23 = stupid 23. +f_equal. -- cgit v1.2.3 From 76bc7f9d164c20583c6561127bf36e7247a37c6b Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 6 Nov 2015 18:19:38 +0100 Subject: Fixing complexity file f_equal.v. --- test-suite/complexity/f_equal.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v index 30e87939ec..86698fa872 100644 --- a/test-suite/complexity/f_equal.v +++ b/test-suite/complexity/f_equal.v @@ -11,4 +11,4 @@ match n with end. Goal stupid 23 = stupid 23. -f_equal. +Timeout 5 Time f_equal. -- cgit v1.2.3 From e9f1b6abaf062e8fbb4892f7ec8856dcf81c2757 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 31 Oct 2015 15:12:02 +0100 Subject: Tests for syntax "Show id" and [id]:tac (shelved or not). --- test-suite/success/destruct.v | 2 ++ 1 file changed, 2 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 83a33f75dc..59cd25cd76 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -97,6 +97,7 @@ Abort. Goal exists x, S x = S 0. eexists. +Show x. (* Incidentally test Show on a named goal *) destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) change (0 = S 0). Abort. @@ -105,6 +106,7 @@ Goal exists x, S 0 = S x. eexists. destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) change (0 = S ?x). +[x]: exact 0. (* Incidentally test applying a tactic to a goal on the shelve *) Abort. Goal exists n p:nat, (S n,S n) = (S p,S p) /\ p = n. -- cgit v1.2.3 From 9e0cabdaf2055a9bef075d122260a96bb51df2aa Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 23:06:14 +0100 Subject: Fixing output test Existentials.v after eec77191b. --- test-suite/output/Existentials.out | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'test-suite') diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out index 483a9ea792..52e1e0ed01 100644 --- a/test-suite/output/Existentials.out +++ b/test-suite/output/Existentials.out @@ -1,5 +1,5 @@ Existential 1 = -?Goal0 : [p : nat q := S p : nat n : nat m : nat |- ?y = m] +?Goal1 : [p : nat q := S p : nat n : nat m : nat |- ?y = m] Existential 2 = ?y : [p : nat q := S p : nat n : nat m : nat |- nat] (p, q cannot be used) -Existential 3 = ?e : [q : nat n : nat m : nat |- n = ?y] +Existential 3 = ?Goal0 : [q : nat n : nat m : nat |- n = ?y] -- cgit v1.2.3 From b382bb1b42319d7be422f92fd196df8bfbe21a83 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 8 Nov 2015 09:47:12 +0100 Subject: Adapting output test inference.v after c23f0cab6 (experimenting printing the type of the defined term of a LetIn). --- test-suite/output/inference.out | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index f2d1447785..c5a393408e 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -6,7 +6,7 @@ fun e : option L => match e with : option L -> option L fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H : forall m n p : nat, S m <= S n + p -> m <= n + p -fun n : nat => let x := A n in ?y ?y0 : T n +fun n : nat => let x := A n : T n in ?y ?y0 : T n : forall n : nat, T n where ?y : [n : nat x := A n : T n |- ?T0 -> T n] -- cgit v1.2.3 From 5587499e721f4aa1f2cf35596a8f7aa58d852592 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 10 Nov 2015 11:17:20 +0100 Subject: Test for bug #4404. --- test-suite/bugs/closed/4404.v | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 test-suite/bugs/closed/4404.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4404.v b/test-suite/bugs/closed/4404.v new file mode 100644 index 0000000000..27b43a61d4 --- /dev/null +++ b/test-suite/bugs/closed/4404.v @@ -0,0 +1,4 @@ +Inductive Foo : Type -> Type := foo A : Foo A. +Goal True. + remember Foo. + -- cgit v1.2.3 From 07620386b3c1b535ee7e43306a6345f015a318f0 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 31 Aug 2015 20:53:45 +0200 Subject: Fixing #1225: we now skip the canonically built binding contexts of the return clause and of the branches in a "match", computing them automatically when using the "at" clause of pattern, destruct, ... In principle, this is a source of incompatibilities in the numbering, since the internal binders of a "match" are now skipped. We shall deal with that later on. --- test-suite/bugs/closed/1225.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 test-suite/bugs/closed/1225.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/1225.v b/test-suite/bugs/closed/1225.v new file mode 100644 index 0000000000..a7799b35fe --- /dev/null +++ b/test-suite/bugs/closed/1225.v @@ -0,0 +1,12 @@ +(* Taking automatically into account internal dependencies of a |match] *) + +Let a n := @exist nat _ _ (refl_equal (n + 1)). +Goal let (n, _) := a 3 in n = 4. +pattern 3 at 1. +Abort. + +Goal match refl_equal 0 in _ = n return n = 0 with + | refl_equal => refl_equal 0 + end = refl_equal 0. +pattern 0 at 1 2 3 4 5 6. +Abort. -- cgit v1.2.3 From d57e30cfe8f68987ed216415079f4dab42065408 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 10 Nov 2015 17:26:36 +0100 Subject: Revert "Fixing #1225: we now skip the canonically built binding contexts of" This reverts commit 07620386b3c1b535ee7e43306a6345f015a318f0. Very sorry not ready. --- test-suite/bugs/closed/1225.v | 12 ------------ 1 file changed, 12 deletions(-) delete mode 100644 test-suite/bugs/closed/1225.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/1225.v b/test-suite/bugs/closed/1225.v deleted file mode 100644 index a7799b35fe..0000000000 --- a/test-suite/bugs/closed/1225.v +++ /dev/null @@ -1,12 +0,0 @@ -(* Taking automatically into account internal dependencies of a |match] *) - -Let a n := @exist nat _ _ (refl_equal (n + 1)). -Goal let (n, _) := a 3 in n = 4. -pattern 3 at 1. -Abort. - -Goal match refl_equal 0 in _ = n return n = 0 with - | refl_equal => refl_equal 0 - end = refl_equal 0. -pattern 0 at 1 2 3 4 5 6. -Abort. -- cgit v1.2.3 From f0ff590f380fb3d9fac6ebfdd6cfd7bf6874658e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 10 Nov 2015 18:43:07 +0100 Subject: Updating test-suite after Bracketing Last Introduction Pattern set by default. Interestingly, there is an example where it makes the rest of the proof less natural. Goal forall x y:Z, ... intros [y|p1[|p2|p2]|p1[|p2|p2]]. where case analysis on y is not only in the 2nd and 3rd case, is not anymore easy to do. Still, I find the bracketing of intro-patterns a natural property, and its generalization in all situations a natural expectation for uniformity. So, what to do? The following is e.g. not as compact and "one-shot": intros [|p1|p1]; [intros y|intros [|p2|p2] ..]. --- test-suite/micromega/square.v | 3 +-- test-suite/output/Cases.v | 2 +- test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v | 20 ++++++++++---------- 3 files changed, 12 insertions(+), 13 deletions(-) (limited to 'test-suite') diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v index 8767f6874e..abf8be72ef 100644 --- a/test-suite/micromega/square.v +++ b/test-suite/micromega/square.v @@ -53,8 +53,7 @@ Qed. Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1. Proof. - unfold Qeq; intros [x]; simpl (Qden (2#1)); rewrite Z.mul_1_r. - intros HQeq. + unfold Qeq; intros (x,HQeq); simpl (Qden (2#1)) in HQeq; rewrite Z.mul_1_r in HQeq. assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by (rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto). assert (Hnx : (Qnum x <> 0)%Z) diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 4116a5ebc2..a95b085ac0 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -73,7 +73,7 @@ Definition f : B -> True. Proof. intros []. -destruct b as [|] ; intros _ ; exact Logic.I. +destruct b as [|] ; exact Logic.I. Defined. Print f. diff --git a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v index 0d75d52a31..06357cfc21 100644 --- a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v +++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v @@ -1902,14 +1902,14 @@ Qed. Lemma Zsgn_15 : forall x y : Z, Zsgn (x * y) = (Zsgn x * Zsgn y)%Z. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; constructor. + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; constructor. Qed. Lemma Zsgn_16 : forall x y : Z, Zsgn (x * y) = 1%Z -> {(0 < x)%Z /\ (0 < y)%Z} + {(x < 0)%Z /\ (y < 0)%Z}. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; try discriminate H; [ left | right ]; repeat split. Qed. @@ -1917,13 +1917,13 @@ Lemma Zsgn_17 : forall x y : Z, Zsgn (x * y) = (-1)%Z -> {(0 < x)%Z /\ (y < 0)%Z} + {(x < 0)%Z /\ (0 < y)%Z}. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; try discriminate H; [ left | right ]; repeat split. Qed. Lemma Zsgn_18 : forall x y : Z, Zsgn (x * y) = 0%Z -> {x = 0%Z} + {y = 0%Z}. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; try discriminate H; [ left | right | right ]; constructor. Qed. @@ -1932,40 +1932,40 @@ Qed. Lemma Zsgn_19 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 < x + y)%Z. Proof. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; discriminate H || (constructor || apply Zsgn_12; assumption). Qed. Lemma Zsgn_20 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x + y < 0)%Z. Proof. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; discriminate H || (constructor || apply Zsgn_11; assumption). Qed. Lemma Zsgn_21 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= x)%Z. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. Lemma Zsgn_22 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x <= 0)%Z. Proof. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. Lemma Zsgn_23 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= y)%Z. Proof. - intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros [|p1|p1] [|p2|p2]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. Lemma Zsgn_24 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (y <= 0)%Z. Proof. - intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros [|p1|p1] [|p2|p2]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. -- cgit v1.2.3 From 701a69732ef2abfc7384296e090a3e9bd7604bbd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 11 Nov 2015 18:45:32 +0100 Subject: Fixing bug #3554: Anomaly: Anonymous implicit argument. We just handle unnamed implicits using a dummy name. Note that the implicit argument logic should still output warnings whenever the user writes implicit arguments that won't be taken into account, but I'll leave that for another time. --- test-suite/bugs/closed/3554.v | 1 + 1 file changed, 1 insertion(+) create mode 100644 test-suite/bugs/closed/3554.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3554.v b/test-suite/bugs/closed/3554.v new file mode 100644 index 0000000000..13a79cc840 --- /dev/null +++ b/test-suite/bugs/closed/3554.v @@ -0,0 +1 @@ +Example foo (f : forall {_ : Type}, Type) : Type. -- cgit v1.2.3 From 2f56f0fcf21902bb1317f1d6f7ba4b593d712646 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 16:04:43 -0500 Subject: Fix bug #4293: ensure let-ins do not contain algebraic universes in their type annotation. --- test-suite/bugs/closed/4293.v | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 test-suite/bugs/closed/4293.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4293.v b/test-suite/bugs/closed/4293.v new file mode 100644 index 0000000000..3671c931b7 --- /dev/null +++ b/test-suite/bugs/closed/4293.v @@ -0,0 +1,7 @@ +Module Type Foo. +Definition T := let X := Type in Type. +End Foo. + +Module M : Foo. +Definition T := let X := Type in Type. +End M. \ No newline at end of file -- cgit v1.2.3 From ca30a8be08beeae77d42b6cb5d9f219e3932a3f7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 17:12:39 -0500 Subject: Fix bug #3257, setoid_reflexivity should fail if not completing the goal. --- test-suite/bugs/closed/3257.v | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 test-suite/bugs/closed/3257.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3257.v b/test-suite/bugs/closed/3257.v new file mode 100644 index 0000000000..d8aa6a0479 --- /dev/null +++ b/test-suite/bugs/closed/3257.v @@ -0,0 +1,5 @@ +Require Import Setoid Morphisms Basics. +Lemma foo A B (P : B -> Prop) : + pointwise_relation _ impl (fun z => A -> P z) P. +Proof. + Fail reflexivity. -- cgit v1.2.3 From 7de9c1a45a354676a073e216f42c34820e454691 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 11 Nov 2015 20:39:41 +0100 Subject: Now closed. --- test-suite/bugs/opened/3554.v | 1 - 1 file changed, 1 deletion(-) delete mode 100644 test-suite/bugs/opened/3554.v (limited to 'test-suite') diff --git a/test-suite/bugs/opened/3554.v b/test-suite/bugs/opened/3554.v deleted file mode 100644 index 422c5770ea..0000000000 --- a/test-suite/bugs/opened/3554.v +++ /dev/null @@ -1 +0,0 @@ -Fail Example foo (f : forall {_ : Type}, Type) : Type. -- cgit v1.2.3 From db002583b18c8742c0cd8e1a12305166b6b791ce Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 12 Nov 2015 12:05:00 +0100 Subject: Fixed test-suite file for bug #3998. --- test-suite/bugs/closed/3998.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 test-suite/bugs/closed/3998.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3998.v b/test-suite/bugs/closed/3998.v new file mode 100644 index 0000000000..ced13839dd --- /dev/null +++ b/test-suite/bugs/closed/3998.v @@ -0,0 +1,24 @@ +Class FieldType (F : Set) := mkFieldType { fldTy: F -> Set }. +Hint Mode FieldType + : typeclass_instances. (* The F parameter is an input *) + +Inductive I1 := C. +Inductive I2 := . + +Instance I1FieldType : FieldType I1 := { fldTy := I1_rect _ bool }. +Instance I2FieldType : FieldType I2 := { fldTy := I2_rect _ }. + +Definition RecordOf F (FT: FieldType F) := forall f:F, fldTy f. + +Class MapOps (M K : Set) := { + tgtTy: K -> Set; + update: M -> forall k:K, tgtTy k -> M +}. + +Instance RecordMapOps F (FT: FieldType F) : MapOps (RecordOf F FT) F := +{ tgtTy := fldTy; update := fun r (f: F) (x: fldTy f) z => r z }. + +Axiom ex : RecordOf _ I1FieldType. + +Definition works := (fun ex' => update ex' C true) (update ex C false). +Set Typeclasses Debug. +Definition doesnt := update (update ex C false) C true. \ No newline at end of file -- cgit v1.2.3 From 0c11bc39927c7756a0e3c3a6c445f20d0daaad7f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 12 Nov 2015 14:14:38 +0100 Subject: Fix bug #4412: [rewrite] (setoid_rewrite?) creates ill-typed terms. We retypecheck the hypotheses introduced by the refine primitive instead of blindly trusting them when the unsafe flag is set to false. --- test-suite/bugs/closed/4412.v | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 test-suite/bugs/closed/4412.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4412.v b/test-suite/bugs/closed/4412.v new file mode 100644 index 0000000000..4b2aae0c7b --- /dev/null +++ b/test-suite/bugs/closed/4412.v @@ -0,0 +1,4 @@ +Require Import Coq.Bool.Bool Coq.Setoids.Setoid. +Goal forall (P : forall b : bool, b = true -> Type) (x y : bool) (H : andb x y = true) (H' : P _ H), True. + intros. + Fail rewrite Bool.andb_true_iff in H. -- cgit v1.2.3 From 73c9ad1ff19915fbaf053119c5498ff1314e92e3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 15 Nov 2015 17:47:24 +0100 Subject: Fixing output test Cases.v. Not sure if this is really what is expected though. --- test-suite/output/Cases.out | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'test-suite') diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 09f032d478..f846f4ee10 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -47,10 +47,10 @@ foo' = if A 0 then true else false f = fun H : B => match H with -| AC x => - (let b0 := b in - if b0 as b return (P b -> True) +| AC H0 => + let b0 := b in + (if b0 as b return (P b -> True) then fun _ : P true => Logic.I - else fun _ : P false => Logic.I) x + else fun _ : P false => Logic.I) H0 end : B -> True -- cgit v1.2.3 From c71aa6bd368b801bb17d4da69d1ab1e2bd7cbf39 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 7 Nov 2015 07:20:34 +0100 Subject: Fixing logical bugs in the presence of let-ins in computiong primitive projections. - lift accounting for the record missing in computing the subst from fields to projections of the record - substitution for parameters should not lift the local definitions - typo in building the latter (subst -> letsubst) --- test-suite/success/primitiveproj.v | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v index 125615c535..281d707cb3 100644 --- a/test-suite/success/primitiveproj.v +++ b/test-suite/success/primitiveproj.v @@ -194,4 +194,17 @@ Record wrap (A : Type) := { unwrap : A; unwrap2 : A }. Definition term (x : wrap nat) := x.(unwrap). Definition term' (x : wrap nat) := let f := (@unwrap2 nat) in f x. Recursive Extraction term term'. -(*Unset Printing Primitive Projection Parameters.*) \ No newline at end of file +(*Unset Printing Primitive Projection Parameters.*) + +(* Primitive projections in the presence of let-ins (was not failing in beta3)*) + +Set Primitive Projections. +Record s (x:nat) (y:=S x) := {c:=x; d:x=c}. +Lemma f : 0=1. +Proof. +Fail apply d. +(* +split. +reflexivity. +Qed. +*) -- cgit v1.2.3 From 574e510ba069f1747ecb1e5a17cf86c902d79d44 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 19 Nov 2015 18:40:32 +0100 Subject: Fix bug #4429: eauto with arith: 70x performance regression in Coq 8.5. The issue was due to the fact that unfold hints are given a priority of 4 by default. As eauto was now using hint priority rather than the number of goals produced to order the application of hints, unfold were almost always used too late. We fixed this by manually giving them a priority of 1 in the eauto tactic. Also fixed the relative order of proof depth w.r.t. hint priority. It should not be observable except for breadth-first search, which is seldom used. --- test-suite/bugs/closed/4429.v | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 test-suite/bugs/closed/4429.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4429.v b/test-suite/bugs/closed/4429.v new file mode 100644 index 0000000000..bf0e570ab8 --- /dev/null +++ b/test-suite/bugs/closed/4429.v @@ -0,0 +1,31 @@ +Require Import Arith.Compare_dec. +Require Import Unicode.Utf8. + +Fixpoint my_nat_iter (n : nat) {A} (f : A → A) (x : A) : A := + match n with + | O => x + | S n' => f (my_nat_iter n' f x) + end. + +Definition gcd_IT_F (f : nat * nat → nat) (mn : nat * nat) : nat := + match mn with + | (0, 0) => 0 + | (0, S n') => S n' + | (S m', 0) => S m' + | (S m', S n') => + match le_gt_dec (S m') (S n') with + | left _ => f (S m', S n' - S m') + | right _ => f (S m' - S n', S n') + end + end. + +Axiom max_correct_l : ∀ m n : nat, m <= max m n. +Axiom max_correct_r : ∀ m n : nat, n <= max m n. + +Hint Resolve max_correct_l max_correct_r : arith. + +Theorem foo : ∀ p p' p'' : nat, p'' < S (max p (max p' p'')). +Proof. + intros. + Timeout 3 eauto with arith. +Qed. -- cgit v1.2.3 From e583a79b5a0298fd08f34305cc876d5117913e95 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 21 Nov 2015 00:23:12 +0100 Subject: Fixing kernel bug in typing match with let-ins in the arity. Was exploitable in 8.3, 8.4 and 8.5beta1. A priori not exploitable in 8.5beta2 and 8.5beta3 from a Coq file because typing done while compiling "match" would serve as a protection. However exploitable by calling the kernel directly, e.g. from a plugin (but a plugin can anyway do what it wants by bypassing kernel type abstraction). Fixing similar error in pretyping. --- test-suite/success/Case22.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index ce9050d421..8c8f02eccf 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -17,3 +17,27 @@ Definition foo (x : I') : bool := match x with C' => true end. + +(* Bug found in november 2015: was wrongly failing in 8.5beta2 and 8.5beta3 *) + +Inductive I2 (A:Type) : let B:=A in forall C, let D:=(C*B)%type in Type := + E2 : I2 A nat. + +Check fun x:I2 nat nat => match x in I2 _ X Y Z return X*Y*Z with + E2 _ => (0,0,(0,0)) + end. + +(* This used to succeed in 8.3, 8.4 and 8.5beta1 *) + +Inductive IND : forall X:Type, let Y:=X in Type := + C : IND True. + +Definition F (x:IND True) (A:Type) := + (* This failed in 8.5beta2 though it should have been accepted *) + match x in IND Y Z return Z with + C => I + end. + +Theorem paradox : False. + (* This succeeded in 8.3, 8.4 and 8.5beta1 because F had wrong type *) +Fail Proof (F C False). -- cgit v1.2.3 From af954522789043202d9c300a0bb37cbaf4958d60 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 22 Nov 2015 17:17:49 +0100 Subject: Fixing a bug of adjust_subst_to_rel_context. --- test-suite/success/Case22.v | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) (limited to 'test-suite') diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index 8c8f02eccf..f88051f8f5 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -30,14 +30,26 @@ Check fun x:I2 nat nat => match x in I2 _ X Y Z return X*Y*Z with (* This used to succeed in 8.3, 8.4 and 8.5beta1 *) Inductive IND : forall X:Type, let Y:=X in Type := - C : IND True. + CONSTR : IND True. Definition F (x:IND True) (A:Type) := (* This failed in 8.5beta2 though it should have been accepted *) - match x in IND Y Z return Z with - C => I + match x in IND X Y return Y with + CONSTR => Logic.I end. Theorem paradox : False. (* This succeeded in 8.3, 8.4 and 8.5beta1 because F had wrong type *) Fail Proof (F C False). + +(* Another bug found in November 2015 (a substitution was wrongly + reversed at pretyping level) *) + +Inductive Ind (A:Type) : + let X:=A in forall Y:Type, let Z:=(X*Y)%type in Type := + Constr : Ind A nat. + +Check fun x:Ind bool nat => + match x in Ind _ X Y Z return Z with + | Constr _ => (true,0) + end. -- cgit v1.2.3 From c4e2cf027b3fade4f9c2806e6061e1294a99e540 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 22 Nov 2015 21:17:59 +0100 Subject: Fixing a vm_compute bug in the presence of let-ins among the parameters of an inductive type. --- test-suite/success/Case22.v | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index f88051f8f5..3c696502cd 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -53,3 +53,11 @@ Check fun x:Ind bool nat => match x in Ind _ X Y Z return Z with | Constr _ => (true,0) end. + +(* A vm_compute bug (the type of constructors was not supposed to + contain local definitions before proper parameters) *) + +Inductive Ind2 (b:=1) (c:nat) : Type := + Constr2 : Ind2 c. + +Eval vm_compute in Constr2 2. -- cgit v1.2.3 From 982460743a54ecfab1d601ba930d61c04972d17a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 26 Nov 2015 19:05:25 +0100 Subject: Fixing the "parsing rules with idents later declared as keywords" problem. The fix was actually elementary. The lexer comes with a function to compare parsed tokens against tokens of the parsing rules. It is enough to have this function considering an ident in a parsing rule to be equal to the corresponding string parsed as a keyword. --- test-suite/success/Notations.v | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 2371d32cda..b72a067407 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -101,3 +101,9 @@ Fail Check fun x => match x with S (FORALL x, _) => 0 end. Parameter traverse : (nat -> unit) -> (nat -> unit). Notation traverse_var f l := (traverse (fun l => f l) l). + +(* Check that when an ident become a keyword, it does not break + previous rules relying on the string to be classified as an ident *) + +Notation "'intros' x" := (S x) (at level 0). +Goal True -> True. intros H. exact H. Qed. -- cgit v1.2.3 From 4a11dc25938f3f009e23f1e7c5fe01b2558928c3 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 27 Nov 2015 20:34:51 +0100 Subject: Univs: entirely disallow instantiation of polymorphic constants with Prop levels. As they are typed assuming all variables are >= Set now, and this was breaking an invariant in typing. Only one instance in the standard library was used in Hurkens, which can be avoided easily. This also avoids displaying unnecessary >= Set constraints everywhere. --- test-suite/bugs/closed/4287.v | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v index 0623cf5b84..43c9b51295 100644 --- a/test-suite/bugs/closed/4287.v +++ b/test-suite/bugs/closed/4287.v @@ -118,8 +118,6 @@ Definition setle (B : Type@{i}) := let foo (A : Type@{j}) := A in foo B. Fail Check @setlt@{j Prop}. -Check @setlt@{Prop j}. -Check @setle@{Prop j}. - Fail Definition foo := @setle@{j Prop}. -Definition foo := @setle@{Prop j}. +Check setlt@{Set i}. +Check setlt@{Set j}. \ No newline at end of file -- cgit v1.2.3 From 15aeb84a0deb444af81f4035dbcf791566bafe5f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 28 Nov 2015 19:43:58 +0100 Subject: Closed bugs. --- test-suite/bugs/closed/3807.v | 33 +++++++++++++++++++++++++++++++++ test-suite/bugs/closed/4400.v | 19 +++++++++++++++++++ test-suite/bugs/closed/4433.v | 29 +++++++++++++++++++++++++++++ 3 files changed, 81 insertions(+) create mode 100644 test-suite/bugs/closed/3807.v create mode 100644 test-suite/bugs/closed/4400.v create mode 100644 test-suite/bugs/closed/4433.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3807.v b/test-suite/bugs/closed/3807.v new file mode 100644 index 0000000000..108ebf592b --- /dev/null +++ b/test-suite/bugs/closed/3807.v @@ -0,0 +1,33 @@ +Set Universe Polymorphism. +Set Printing Universes. +Unset Universe Minimization ToSet. + + +Definition foo : Type := nat. +About foo. +(* foo@{Top.1} : Type@{Top.1}*) +(* Top.1 |= *) + +Definition bar : foo -> nat. +Admitted. +About bar. +(* bar@{Top.2} : foo@{Top.2} -> nat *) +(* Top.2 |= *) + +Lemma baz@{i} : foo@{i} -> nat. +Proof. + exact bar. +Defined. + +Definition bar'@{i} : foo@{i} -> nat. + intros f. exact 0. +Admitted. +About bar'. +(* bar'@{i} : foo@{i} -> nat *) +(* i |= *) + +Axiom f@{i} : Type@{i}. +(* +*** [ f@{i} : Type@{i} ] +(* i |= *) +*) \ No newline at end of file diff --git a/test-suite/bugs/closed/4400.v b/test-suite/bugs/closed/4400.v new file mode 100644 index 0000000000..5c23f8404b --- /dev/null +++ b/test-suite/bugs/closed/4400.v @@ -0,0 +1,19 @@ +(* -*- coq-prog-args: ("-emacs" "-require" "Coq.Compat.Coq84" "-compat" "8.4") -*- *) +Require Import Coq.Lists.List Coq.Logic.JMeq Program.Equality. +Set Printing Universes. +Inductive Foo (I : Type -> Type) (A : Type) : Type := +| foo (B : Type) : A -> I B -> Foo I A. +Definition Family := Type -> Type. +Definition FooToo : Family -> Family := Foo. +Definition optionize (I : Type -> Type) (A : Type) := option (I A). +Definition bar (I : Type -> Type) (A : Type) : A -> option (I A) -> Foo(optionize I) A := foo (optionize I) A A. +Record Rec (I : Type -> Type) := { rec : forall A : Type, A -> I A -> Foo I A }. +Definition barRec : Rec (optionize id) := {| rec := bar id |}. +Inductive Empty {T} : T -> Prop := . +Theorem empty (family : Family) (a : fold_right prod unit (map (Foo family) +nil)) (b : unit) : + Empty (a, b) -> False. +Proof. + intro e. + dependent induction e. +Qed. diff --git a/test-suite/bugs/closed/4433.v b/test-suite/bugs/closed/4433.v new file mode 100644 index 0000000000..9eeb864689 --- /dev/null +++ b/test-suite/bugs/closed/4433.v @@ -0,0 +1,29 @@ +Require Import Coq.Arith.Arith Coq.Init.Wf. +Axiom proof_admitted : False. +Goal exists x y z : nat, Fix + Wf_nat.lt_wf + (fun _ => nat -> nat) + (fun x' f => match x' as x'0 + return match x'0 with + | 0 => True + | S x'' => x'' < x' + end + -> nat -> nat + with + | 0 => fun _ _ => 0 + | S x'' => f x'' + end + (match x' with + | 0 => I + | S x'' => (Nat.lt_succ_diag_r _) + end)) + z + y + = 0. +Proof. + do 3 (eexists; [ shelve.. | ]). + match goal with |- ?G => let G' := (eval lazy in G) in change G with G' end. + case proof_admitted. + Unshelve. + all:constructor. +Defined. \ No newline at end of file -- cgit v1.2.3 From 8d6e58e16cc53a3198eb4c4afef0a2c39f6a5c56 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 28 Nov 2015 20:02:52 +0100 Subject: Test-suite files for closed bugs --- test-suite/bugs/closed/3735.v | 4 ++++ test-suite/bugs/closed/4284.v | 6 ++++++ 2 files changed, 10 insertions(+) create mode 100644 test-suite/bugs/closed/3735.v create mode 100644 test-suite/bugs/closed/4284.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3735.v b/test-suite/bugs/closed/3735.v new file mode 100644 index 0000000000..a50572ace0 --- /dev/null +++ b/test-suite/bugs/closed/3735.v @@ -0,0 +1,4 @@ +Require Import Coq.Program.Tactics. +Class Foo := { bar : Type }. +Fail Lemma foo : Foo -> bar. (* 'Command has indeed failed.' in both 8.4 and trunk *) +Fail Program Lemma foo : Foo -> bar. \ No newline at end of file diff --git a/test-suite/bugs/closed/4284.v b/test-suite/bugs/closed/4284.v new file mode 100644 index 0000000000..0fff3026ff --- /dev/null +++ b/test-suite/bugs/closed/4284.v @@ -0,0 +1,6 @@ +Set Primitive Projections. +Record total2 { T: Type } ( P: T -> Type ) := tpair { pr1 : T; pr2 : P pr1 }. +Theorem onefiber' {X : Type} (P : X -> Type) (x : X) : True. +Proof. +set (Q1 := total2 (fun f => pr1 P f = x)). +set (f1:=fun q1 : Q1 => pr2 _ (pr1 _ q1)). -- cgit v1.2.3 From 30efd8d3501ff724e6f75acf7c2355a107da1c70 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 30 Nov 2015 12:36:04 +0100 Subject: Test for bug #4149. --- test-suite/bugs/closed/4149.v | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 test-suite/bugs/closed/4149.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4149.v b/test-suite/bugs/closed/4149.v new file mode 100644 index 0000000000..b81c680cd7 --- /dev/null +++ b/test-suite/bugs/closed/4149.v @@ -0,0 +1,4 @@ +Goal forall A, A -> Type. +Proof. + intros; eauto. +Qed. -- cgit v1.2.3 From 551a03d3e50d067b4b10669b6b302692e6ac3081 Mon Sep 17 00:00:00 2001 From: Jacques-Henri Jourdan Date: Fri, 10 Jul 2015 16:20:33 +0200 Subject: New algorithm for universe cycle detections. --- test-suite/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/Makefile b/test-suite/Makefile index 31b2129001..6274183b36 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -388,7 +388,7 @@ misc/deps-order.log: } > "$@" # Sort universes for the whole standard library -EXPECTED_UNIVERSES := 5 +EXPECTED_UNIVERSES := 4 # Prop is not counted universes: misc/universes.log misc/universes.log: misc/universes/all_stdlib.v @echo "TEST misc/universes" -- cgit v1.2.3 From 9205d8dc7b9e97b6c2f0815fddc5673c21d11089 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 2 Nov 2015 12:26:53 +0100 Subject: Changing syntax "$(tactic)$" into "ltac:(tactic)", as discussed in WG. --- test-suite/bugs/closed/3249.v | 4 ++-- test-suite/bugs/closed/3285.v | 2 +- test-suite/bugs/closed/3286.v | 8 ++++---- test-suite/bugs/closed/3314.v | 4 ++-- test-suite/bugs/closed/3330.v | 2 +- test-suite/bugs/closed/3347.v | 2 +- test-suite/bugs/closed/3354.v | 2 +- test-suite/bugs/closed/3467.v | 2 +- test-suite/bugs/closed/3487.v | 2 +- test-suite/bugs/closed/3682.v | 2 +- test-suite/bugs/closed/3684.v | 2 +- test-suite/bugs/closed/3690.v | 2 +- test-suite/bugs/closed/3881.v | 2 +- test-suite/bugs/closed/HoTT_coq_077.v | 2 +- test-suite/bugs/closed/HoTT_coq_114.v | 2 +- test-suite/bugs/opened/3248.v | 4 ++-- test-suite/bugs/opened/3277.v | 2 +- test-suite/bugs/opened/3278.v | 8 ++++---- test-suite/bugs/opened/3304.v | 2 +- test-suite/bugs/opened/3459.v | 4 ++-- test-suite/success/polymorphism.v | 4 ++-- 21 files changed, 32 insertions(+), 32 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3249.v b/test-suite/bugs/closed/3249.v index d41d231739..71d457b002 100644 --- a/test-suite/bugs/closed/3249.v +++ b/test-suite/bugs/closed/3249.v @@ -5,7 +5,7 @@ Ltac ret_and_left T := lazymatch eval hnf in t with | ?a /\ ?b => constr:(proj1 T) | forall x : ?T', @?f x => - constr:(fun x : T' => $(let fx := constr:(T x) in + constr:(fun x : T' => ltac:(let fx := constr:(T x) in let t := ret_and_left fx in - exact t)$) + exact t)) end. diff --git a/test-suite/bugs/closed/3285.v b/test-suite/bugs/closed/3285.v index 25162329ef..68e6b7386f 100644 --- a/test-suite/bugs/closed/3285.v +++ b/test-suite/bugs/closed/3285.v @@ -1,7 +1,7 @@ Goal True. Proof. match goal with - | _ => let x := constr:($(fail)$) in idtac + | _ => let x := constr:(ltac:(fail)) in idtac | _ => idtac end. Abort. diff --git a/test-suite/bugs/closed/3286.v b/test-suite/bugs/closed/3286.v index b08b7ab3cc..701480fc83 100644 --- a/test-suite/bugs/closed/3286.v +++ b/test-suite/bugs/closed/3286.v @@ -6,20 +6,20 @@ Ltac make_apply_under_binders_in lem H := | forall x : ?T, @?P x => let ret := constr:(fun x' : T => let Hx := H x' in - $(let ret' := tac lem Hx in - exact ret')$) in + ltac:(let ret' := tac lem Hx in + exact ret')) in match eval cbv zeta in ret with | fun x => Some (@?P x) => let P' := (eval cbv zeta in P) in constr:(Some P') end - | _ => let ret := constr:($(match goal with + | _ => let ret := constr:(ltac:(match goal with | _ => (let H' := fresh in pose H as H'; apply lem in H'; exact (Some H')) | _ => exact (@None nat) end - )$) in + )) in let ret' := (eval cbv beta zeta in ret) in constr:(ret') | _ => constr:(@None nat) diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v index fb3791af55..a5782298c3 100644 --- a/test-suite/bugs/closed/3314.v +++ b/test-suite/bugs/closed/3314.v @@ -1,9 +1,9 @@ Require Import TestSuite.admit. Set Universe Polymorphism. Definition Lift -: $(let U1 := constr:(Type) in +: ltac:(let U1 := constr:(Type) in let U0 := constr:(Type : U1) in - exact (U0 -> U1))$ + exact (U0 -> U1)) := fun T => T. Fail Check nat:Prop. (* The command has indeed failed with message: diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v index e6a50449da..e3b5e94356 100644 --- a/test-suite/bugs/closed/3330.v +++ b/test-suite/bugs/closed/3330.v @@ -8,7 +8,7 @@ Inductive foo : Type@{l} := bar : foo . Section MakeEq. Variables (a : foo@{i}) (b : foo@{j}). - Let t := $(let ty := type of b in exact ty)$. + Let t := ltac:(let ty := type of b in exact ty). Definition make_eq (x:=b) := a : t. End MakeEq. diff --git a/test-suite/bugs/closed/3347.v b/test-suite/bugs/closed/3347.v index 63d5c7a57b..dcf5394eaf 100644 --- a/test-suite/bugs/closed/3347.v +++ b/test-suite/bugs/closed/3347.v @@ -1,7 +1,7 @@ Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12653 lines to 12453 lines, then from 11673 lines to 681 lines, then from 693 lines to 469 lines, then from 375 lines to 56 lines *) Set Universe Polymorphism. -Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Notation Type1 := ltac:(let U := constr:(Type) in let gt := constr:(Set : U) in exact U) (only parsing). Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. Inductive Unit : Type1 := tt : Unit. Fail Check Unit : Set. (* [Check Unit : Set] should fail if [Type1] is defined correctly *) diff --git a/test-suite/bugs/closed/3354.v b/test-suite/bugs/closed/3354.v index 14b66db362..a635285f2c 100644 --- a/test-suite/bugs/closed/3354.v +++ b/test-suite/bugs/closed/3354.v @@ -1,5 +1,5 @@ Set Universe Polymorphism. -Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Notation Type1 := ltac:(let U := constr:(Type) in let gt := constr:(Set : U) in exact U) (only parsing). Inductive Empty : Type1 := . Fail Check Empty : Set. (* Toplevel input, characters 15-116: diff --git a/test-suite/bugs/closed/3467.v b/test-suite/bugs/closed/3467.v index 7e37116249..88ae030578 100644 --- a/test-suite/bugs/closed/3467.v +++ b/test-suite/bugs/closed/3467.v @@ -1,5 +1,5 @@ Module foo. - Notation x := $(exact I)$. + Notation x := ltac:(exact I). End foo. Module bar. Include foo. diff --git a/test-suite/bugs/closed/3487.v b/test-suite/bugs/closed/3487.v index 03c60a8baa..1321a8598c 100644 --- a/test-suite/bugs/closed/3487.v +++ b/test-suite/bugs/closed/3487.v @@ -1,4 +1,4 @@ -Notation bar := $(exact I)$. +Notation bar := ltac:(exact I). Notation foo := bar (only parsing). Class baz := { x : False }. Instance: baz. diff --git a/test-suite/bugs/closed/3682.v b/test-suite/bugs/closed/3682.v index 2a282d221f..9d37d1a2d0 100644 --- a/test-suite/bugs/closed/3682.v +++ b/test-suite/bugs/closed/3682.v @@ -3,4 +3,4 @@ Class Foo. Definition bar `{Foo} (x : Set) := Set. Instance: Foo. Definition bar1 := bar nat. -Definition bar2 := bar $(admit)$. +Definition bar2 := bar ltac:(admit). diff --git a/test-suite/bugs/closed/3684.v b/test-suite/bugs/closed/3684.v index f7b137386b..130d57779d 100644 --- a/test-suite/bugs/closed/3684.v +++ b/test-suite/bugs/closed/3684.v @@ -1,5 +1,5 @@ Require Import TestSuite.admit. Definition foo : Set. Proof. - refine ($(abstract admit)$). + refine (ltac:(abstract admit)). Qed. diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v index df9f5f4761..c24173abf1 100644 --- a/test-suite/bugs/closed/3690.v +++ b/test-suite/bugs/closed/3690.v @@ -18,7 +18,7 @@ Top.8} Top.6 Top.7 Top.8 |= *) *) -Definition bar := $(let t := eval compute in foo in exact t)$. +Definition bar := ltac:(let t := eval compute in foo in exact t). Check @bar. (* bar@{Top.13 Top.14 Top.15 Top.16} : Type@{Top.16+1} diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v index 4408ab885d..070d1e9c71 100644 --- a/test-suite/bugs/closed/3881.v +++ b/test-suite/bugs/closed/3881.v @@ -8,7 +8,7 @@ Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Notation "A -> B" := (forall (_ : A), B) : type_scope. Axiom admit : forall {T}, T. Notation "g 'o' f" := (fun x => g (f x)) (at level 40, left associativity). -Notation "g 'o' f" := $(let g' := g in let f' := f in exact (fun x => g' (f' x)))$ (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *) +Notation "g 'o' f" := ltac:(let g' := g in let f' := f in exact (fun x => g' (f' x))) (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *) Inductive eq {A} (x:A) : A -> Prop := eq_refl : x = x where "x = y" := (@eq _ x y) : type_scope. Arguments eq_refl {_ _}. Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with eq_refl => eq_refl end. diff --git a/test-suite/bugs/closed/HoTT_coq_077.v b/test-suite/bugs/closed/HoTT_coq_077.v index db3b60edae..017780c1f3 100644 --- a/test-suite/bugs/closed/HoTT_coq_077.v +++ b/test-suite/bugs/closed/HoTT_coq_077.v @@ -30,7 +30,7 @@ Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B) (p : prod A B) : P p := u (fst p) (snd p). -Notation typeof x := ($(let T := type of x in exact T)$) (only parsing). +Notation typeof x := (ltac:(let T := type of x in exact T)) (only parsing). (* Check for eta *) Check eq_refl : typeof (@prod_rect) = typeof (@prod_rect'). diff --git a/test-suite/bugs/closed/HoTT_coq_114.v b/test-suite/bugs/closed/HoTT_coq_114.v index 341128338e..3535e6c41f 100644 --- a/test-suite/bugs/closed/HoTT_coq_114.v +++ b/test-suite/bugs/closed/HoTT_coq_114.v @@ -1 +1 @@ -Inductive test : $(let U := type of Type in exact U)$ := t. +Inductive test : ltac:(let U := type of Type in exact U) := t. diff --git a/test-suite/bugs/opened/3248.v b/test-suite/bugs/opened/3248.v index 9e7d1eb5dd..33c408a28c 100644 --- a/test-suite/bugs/opened/3248.v +++ b/test-suite/bugs/opened/3248.v @@ -3,7 +3,7 @@ Ltac ret_and_left f := let T := type of f in lazymatch eval hnf in T with | ?T' -> _ => - let ret := constr:(fun x' : T' => $(tac (f x'))$) in + let ret := constr:(fun x' : T' => ltac:(tac (f x'))) in exact ret | ?T' => exact f end. @@ -12,6 +12,6 @@ Goal forall A B : Prop, forall x y : A, True. Proof. intros A B x y. pose (f := fun (x y : A) => conj x y). - pose (a := $(ret_and_left f)$). + pose (a := ltac:(ret_and_left f)). Fail unify (a x y) (conj x y). Abort. diff --git a/test-suite/bugs/opened/3277.v b/test-suite/bugs/opened/3277.v index 19ed787d1e..5f4231363a 100644 --- a/test-suite/bugs/opened/3277.v +++ b/test-suite/bugs/opened/3277.v @@ -4,4 +4,4 @@ Goal True. evarr _. Admitted. Goal True. - Fail exact $(evarr _)$. (* Error: Cannot infer this placeholder. *) + Fail exact ltac:(evarr _). (* Error: Cannot infer this placeholder. *) diff --git a/test-suite/bugs/opened/3278.v b/test-suite/bugs/opened/3278.v index ced535afd5..1c6deae94b 100644 --- a/test-suite/bugs/opened/3278.v +++ b/test-suite/bugs/opened/3278.v @@ -1,8 +1,8 @@ Module a. Check let x' := _ in - $(exact x')$. + ltac:(exact x'). - Notation foo x := (let x' := x in $(exact x')$). + Notation foo x := (let x' := x in ltac:(exact x')). Fail Check foo _. (* Error: Cannot infer an internal placeholder of type "Type" in environment: @@ -12,10 +12,10 @@ x' := ?42 : ?41 End a. Module b. - Notation foo x := (let x' := x in let y := ($(exact I)$ : True) in I). + Notation foo x := (let x' := x in let y := (ltac:(exact I) : True) in I). Notation bar x := (let x' := x in let y := (I : True) in I). - Check let x' := _ in $(exact I)$. (* let x' := ?5 in I *) + Check let x' := _ in ltac:(exact I). (* let x' := ?5 in I *) Check bar _. (* let x' := ?9 in let y := I in I *) Fail Check foo _. (* Error: Cannot infer an internal placeholder of type "Type" in environment: diff --git a/test-suite/bugs/opened/3304.v b/test-suite/bugs/opened/3304.v index 529cc737df..66668930c7 100644 --- a/test-suite/bugs/opened/3304.v +++ b/test-suite/bugs/opened/3304.v @@ -1,3 +1,3 @@ -Fail Notation "( x , y , .. , z )" := $(let r := constr:(prod .. (prod x y) .. z) in r)$. +Fail Notation "( x , y , .. , z )" := ltac:(let r := constr:(prod .. (prod x y) .. z) in r). (* The command has indeed failed with message: => Error: Special token .. is for use in the Notation command. *) diff --git a/test-suite/bugs/opened/3459.v b/test-suite/bugs/opened/3459.v index 9e6107b30a..762611f751 100644 --- a/test-suite/bugs/opened/3459.v +++ b/test-suite/bugs/opened/3459.v @@ -7,9 +7,9 @@ Proof. (* This line used to fail with a Not_found up to some point, and then to produce an ill-typed term *) match goal with - | [ |- context G[2] ] => let y := constr:(fun x => $(let r := constr:(@eq Set x x) in + | [ |- context G[2] ] => let y := constr:(fun x => ltac:(let r := constr:(@eq Set x x) in clear x; - exact r)$) in + exact r)) in pose y end. (* Add extra test for typability (should not fail when bug closed) *) diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index d6bbfe29ac..878875bd92 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -242,7 +242,7 @@ Fail Check (Prop : Set). Fail Check (Set : Set). Check (Set : Type). Check (Prop : Type). -Definition setType := $(let t := type of Set in exact t)$. +Definition setType := ltac:(let t := type of Set in exact t). Definition foo (A : Prop) := A. @@ -303,7 +303,7 @@ Set Printing Universes. Axiom admit : forall A, A. Record R := {O : Type}. -Definition RL (x : R@{i}) : $(let u := constr:(Type@{i}:Type@{j}) in exact (R@{j}) )$ := {|O := @O x|}. +Definition RL (x : R@{i}) : ltac:(let u := constr:(Type@{i}:Type@{j}) in exact (R@{j}) ) := {|O := @O x|}. Definition RLRL : forall x : R, RL x = RL (RL x) := fun x => eq_refl. Definition RLRL' : forall x : R, RL x = RL (RL x). intros. apply eq_refl. -- cgit v1.2.3 From 6ab4479dfa0f9b8fd4df4342fdfdab6c25b62fb7 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 2 Dec 2015 12:10:53 +0100 Subject: Improving syntax of pat/constr introduction pattern so that pat/c1/.../cn behaves as intro H; apply c1, ... , cn in H as pat. Open to other suggestions of syntax though. --- test-suite/success/intros.v | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 35ba94fb67..741f372ff2 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -69,3 +69,12 @@ intros H (H1,?)/H. change (1=1) in H0. exact H1. Qed. + +(* Checking iterated pat/c1.../cn introduction patterns and side conditions *) + +Goal forall A B C D:Prop, (A -> B -> C) -> (C -> D) -> B -> A -> D. +intros * H H0 H1. +intros H2/H/H0. +- exact H2. +- exact H1. +Qed. -- cgit v1.2.3 From 6316e8b380a9942cd587f250eb4a69668e52019e Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 2 Dec 2015 18:24:03 +0100 Subject: Adding a target report to test-suite's Makefile to get a short summary. --- test-suite/Makefile | 3 +++ 1 file changed, 3 insertions(+) (limited to 'test-suite') diff --git a/test-suite/Makefile b/test-suite/Makefile index 31b2129001..7150d1fd4f 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -154,6 +154,9 @@ summary.log: $(SHOW) SUMMARY $(HIDE)$(MAKE) --quiet summary > "$@" +report: summary.log + $(HIDE)if grep -F 'Error!' summary.log ; then false; fi + ####################################################################### # Regression (and progression) tests ####################################################################### -- cgit v1.2.3 From f41968d8c240db4653d0b9fe76e1646cd7c6fb68 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 3 Dec 2015 19:08:51 +0100 Subject: Univs: fix bug #4443. Do not substitute rigid variables during minimization, keeping their equality constraints instead. --- test-suite/bugs/closed/4443.v | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 test-suite/bugs/closed/4443.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4443.v b/test-suite/bugs/closed/4443.v new file mode 100644 index 0000000000..66dfa0e685 --- /dev/null +++ b/test-suite/bugs/closed/4443.v @@ -0,0 +1,31 @@ +Set Universe Polymorphism. + +Record TYPE@{i} := cType { + type : Type@{i}; +}. + +Definition PROD@{i j k} + (A : Type@{i}) + (B : A -> Type@{j}) + : TYPE@{k}. +Proof. + refine (cType@{i} _). ++ refine (forall x : A, B x). +Defined. + +Local Unset Strict Universe Declaration. +Definition PRODinj + (A : Type@{i}) + (B : A -> Type) + : TYPE. +Proof. + refine (cType@{i} _). ++ refine (forall x : A, B x). +Defined. + + Monomorphic Universe i j. + Monomorphic Constraint j < i. +Set Printing Universes. +Check PROD@{i i i}. +Check PRODinj@{i j}. +Fail Check PRODinj@{j i}. \ No newline at end of file -- cgit v1.2.3 From 387351b4c0ffeff65d8a7192f5073cfd4bd20f53 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Dec 2015 00:14:37 +0100 Subject: Changing "destruct !hyp" into "destruct (hyp)" (and similarly for induction) based on a suggestion of Guillaume M. (done like this in ssreflect). This is actually consistent with the hack of using "destruct (1)" to mean the term 1 by opposition to the use of "destruct 1" to mean the first non-dependent hypothesis of the goal. --- test-suite/success/destruct.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 59cd25cd76..9f091e3996 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -389,7 +389,7 @@ Abort. Goal forall b:bool, True. intro b. -destruct !b. +destruct (b). clear b. (* b has to be here *) Abort. -- cgit v1.2.3 From f4002e6c85f575fc8451adb80dba705795f0a0c9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 19 Nov 2015 22:35:03 +0100 Subject: Using x in output test-suite Cases.v (cosmetic). --- test-suite/output/Cases.out | 4 ++-- test-suite/output/Cases.v | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'test-suite') diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index f846f4ee10..f44465456f 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -47,10 +47,10 @@ foo' = if A 0 then true else false f = fun H : B => match H with -| AC H0 => +| AC x => let b0 := b in (if b0 as b return (P b -> True) then fun _ : P true => Logic.I - else fun _ : P false => Logic.I) H0 + else fun _ : P false => Logic.I) x end : B -> True diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index a95b085ac0..a4d19d6930 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -72,7 +72,7 @@ Inductive B : Prop := AC : P b -> B. Definition f : B -> True. Proof. -intros []. +intros [x]. destruct b as [|] ; exact Logic.I. Defined. -- cgit v1.2.3 From df3a49a18c5b01984000df9244ecea9c275b30cd Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Mon, 7 Dec 2015 10:52:14 +0100 Subject: Fix some typos. --- test-suite/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/Makefile b/test-suite/Makefile index 7150d1fd4f..207f25ed0b 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -352,7 +352,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v fi; \ } > "$@" -# Additionnal dependencies for module tests +# Additional dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo modules/%.vo: modules/%.v $(HIDE)$(coqtop) -R modules Mods -compile $< -- cgit v1.2.3 From 8e7803224eeb32e83600905c2c855e32e7bf8ffb Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 9 Nov 2015 16:22:18 -0800 Subject: bug fixes to vm computation + test cases. --- test-suite/kernel/vm-univ.v | 145 -------------------------------- test-suite/success/vm_univ_poly.v | 141 +++++++++++++++++++++++++++++++ test-suite/success/vm_univ_poly_match.v | 28 ++++++ 3 files changed, 169 insertions(+), 145 deletions(-) delete mode 100644 test-suite/kernel/vm-univ.v create mode 100644 test-suite/success/vm_univ_poly.v create mode 100644 test-suite/success/vm_univ_poly_match.v (limited to 'test-suite') diff --git a/test-suite/kernel/vm-univ.v b/test-suite/kernel/vm-univ.v deleted file mode 100644 index 1bdba3c68d..0000000000 --- a/test-suite/kernel/vm-univ.v +++ /dev/null @@ -1,145 +0,0 @@ -(* Basic tests *) -Polymorphic Definition pid {T : Type} (x : T) : T := x. -(* -Definition _1 : pid true = true := - @eq_refl _ true <: pid true = true. - -Polymorphic Definition a_type := Type. - -Definition _2 : a_type@{i} = Type@{i} := - @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. - -Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := - forall x : T, P x. - -Polymorphic Axiom todo : forall {T:Type}, T -> T. - -Polymorphic Definition todo' (T : Type) := @todo T. - -Definition _3 : @todo'@{Set} = @todo@{Set} := - @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. -*) - -(* Inductive Types *) -Inductive sumbool (A B : Prop) : Set := -| left : A -> sumbool A B -| right : B -> sumbool A B. - -Definition x : sumbool True False := left _ _ I. - -Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := - match H with - | left _ _ x => left _ _ x - | right _ _ x => right _ _ x - end. - -Definition _4 : sumbool_copy x = x := - @eq_refl _ x <: sumbool_copy x = x. - -(* Polymorphic Inductive Types *) -Polymorphic Inductive poption (T : Type@{i}) : Type@{i} := -| PSome : T -> poption@{i} T -| PNone : poption@{i} T. - -Polymorphic Definition poption_default {T : Type@{i}} (p : poption@{i} T) (x : T) : T := - match p with - | @PSome _ y => y - | @PNone _ => x - end. - -Polymorphic Inductive plist (T : Type@{i}) : Type@{i} := -| pnil -| pcons : T -> plist@{i} T -> plist@{i} T. - -Arguments pnil {_}. -Arguments pcons {_} _ _. - -Section pmap. - Context {T : Type@{i}} {U : Type@{j}} (f : T -> U). - - Polymorphic Fixpoint pmap (ls : plist@{i} T) : plist@{j} U := - match ls with - | @pnil _ => @pnil _ - | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) - end. -End pmap. - -Universe Ubool. -Inductive tbool : Type@{Ubool} := ttrue | tfalse. - - -Eval vm_compute in pmap pid (pcons true (pcons false pnil)). -Eval vm_compute in pmap (fun x => match x with - | pnil => true - | pcons _ _ => false - end) (pcons pnil (pcons (pcons false pnil) pnil)). -Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). - -Polymorphic Inductive Tree (T : Type@{i}) : Type@{i} := -| Empty -| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. - -Section pfold. - Context {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U). - - Polymorphic Fixpoint pfold (acc : U) (ls : plist@{i} T) : U := - match ls with - | pnil => acc - | pcons a b => pfold (f a acc) b - end. -End pfold. - -Polymorphic Inductive nat : Type@{i} := -| O -| S : nat -> nat. - -Fixpoint nat_max (a b : nat) : nat := - match a , b with - | O , b => b - | a , O => a - | S a , S b => S (nat_max a b) - end. - -Polymorphic Fixpoint height {T : Type@{i}} (t : Tree@{i} T) : nat := - match t with - | Empty _ => O - | Branch _ ls => S (pfold nat_max O (pmap height ls)) - end. - -Polymorphic Fixpoint repeat {T : Type@{i}} (n : nat) (v : T) : plist@{i} T := - match n with - | O => pnil - | S n => pcons v (repeat n v) - end. - -Polymorphic Fixpoint big_tree (n : nat) : Tree@{i} nat := - match n with - | O => @Empty nat - | S n' => Branch _ (repeat n' (big_tree n')) - end. - -Eval compute in height (big_tree (S (S (S O)))). - -Let big := S (S (S (S (S O)))). -Polymorphic Definition really_big := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). - -Time Definition _5 : height (@Empty nat) = O := - @eq_refl nat O <: height (@Empty nat) = O. - -Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := - @eq_refl nat@{Set} (S@{Set} O@{Set}) <: height@{Set} (@Branch nat pnil) = S O. - -Time Definition _7 : height (big_tree big) = big := - @eq_refl nat big <: height (big_tree big) = big. - -Time Definition _8 : height (big_tree really_big) = really_big := - @eq_refl nat@{Set} (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} - (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) - <: - @eq nat@{Set} - (@height nat@{Set} (big_tree really_big@{Set})) - really_big@{Set}. diff --git a/test-suite/success/vm_univ_poly.v b/test-suite/success/vm_univ_poly.v new file mode 100644 index 0000000000..58fa39743d --- /dev/null +++ b/test-suite/success/vm_univ_poly.v @@ -0,0 +1,141 @@ +(* Basic tests *) +Polymorphic Definition pid {T : Type} (x : T) : T := x. +(* +Definition _1 : pid true = true := + @eq_refl _ true <: pid true = true. + +Polymorphic Definition a_type := Type. + +Definition _2 : a_type@{i} = Type@{i} := + @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. + +Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := + forall x : T, P x. + +Polymorphic Axiom todo : forall {T:Type}, T -> T. + +Polymorphic Definition todo' (T : Type) := @todo T. + +Definition _3 : @todo'@{Set} = @todo@{Set} := + @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. +*) + +(* Inductive Types *) +Inductive sumbool (A B : Prop) : Set := +| left : A -> sumbool A B +| right : B -> sumbool A B. + +Definition x : sumbool True False := left _ _ I. + +Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := + match H with + | left _ _ x => left _ _ x + | right _ _ x => right _ _ x + end. + +Definition _4 : sumbool_copy x = x := + @eq_refl _ x <: sumbool_copy x = x. + +(* Polymorphic Inductive Types *) +Polymorphic Inductive poption@{i} (T : Type@{i}) : Type@{i} := +| PSome : T -> poption@{i} T +| PNone : poption@{i} T. + +Polymorphic Definition poption_default@{i} {T : Type@{i}} (p : poption@{i} T) (x : T) : T := + match p with + | @PSome _ y => y + | @PNone _ => x + end. + +Polymorphic Inductive plist@{i} (T : Type@{i}) : Type@{i} := +| pnil +| pcons : T -> plist@{i} T -> plist@{i} T. + +Arguments pnil {_}. +Arguments pcons {_} _ _. + +Polymorphic Definition pmap@{i j} + {T : Type@{i}} {U : Type@{j}} (f : T -> U) := + fix pmap (ls : plist@{i} T) : plist@{j} U := + match ls with + | @pnil _ => @pnil _ + | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) + end. + +Universe Ubool. +Inductive tbool : Type@{Ubool} := ttrue | tfalse. + + +Eval vm_compute in pmap pid (pcons true (pcons false pnil)). +Eval vm_compute in pmap (fun x => match x with + | pnil => true + | pcons _ _ => false + end) (pcons pnil (pcons (pcons false pnil) pnil)). +Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). + +Polymorphic Inductive Tree@{i} (T : Type@{i}) : Type@{i} := +| Empty +| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. + +Polymorphic Definition pfold@{i u} + {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U) := + fix pfold (acc : U) (ls : plist@{i} T) : U := + match ls with + | pnil => acc + | pcons a b => pfold (f a acc) b + end. + +Polymorphic Inductive nat@{i} : Type@{i} := +| O +| S : nat -> nat. + +Polymorphic Fixpoint nat_max@{i} (a b : nat@{i}) : nat@{i} := + match a , b with + | O , b => b + | a , O => a + | S a , S b => S (nat_max a b) + end. + +Polymorphic Fixpoint height@{i} {T : Type@{i}} (t : Tree@{i} T) : nat@{i} := + match t return nat@{i} with + | Empty _ => O + | Branch _ ls => S@{i} (pfold@{i i} nat_max O (pmap height ls)) + end. + +Polymorphic Fixpoint repeat@{i} {T : Type@{i}} (n : nat@{i}) (v : T) : plist@{i} T := + match n return plist@{i} T with + | O => pnil + | S n => pcons@{i} v (repeat n v) + end. + +Polymorphic Fixpoint big_tree@{i} (n : nat@{i}) : Tree@{i} nat@{i} := + match n with + | O => @Empty nat@{i} + | S n' => Branch@{i} nat@{i} (repeat@{i} n' (big_tree@{i} n')) + end. + +Eval compute in height (big_tree (S (S (S O)))). + +Let big := S (S (S (S (S O)))). +Polymorphic Definition really_big@{i} := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). + +Time Definition _5 : height (@Empty nat) = O := + @eq_refl nat O <: height (@Empty nat) = O. + +Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := + @eq_refl nat@{Set} (S@{Set} O@{Set}) <: @eq nat@{Set} (height@{Set} (@Branch@{Set} nat@{Set} (@pnil@{Set} (Tree@{Set} nat@{Set})))) (S@{Set} O@{Set}). + +Time Definition _7 : height (big_tree big) = big := + @eq_refl nat big <: height (big_tree big) = big. + +Time Definition _8 : height (big_tree really_big) = really_big := + @eq_refl nat@{Set} (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) + <: + @eq nat@{Set} + (@height nat@{Set} (big_tree really_big@{Set})) + really_big@{Set}. diff --git a/test-suite/success/vm_univ_poly_match.v b/test-suite/success/vm_univ_poly_match.v new file mode 100644 index 0000000000..abe6d0fe07 --- /dev/null +++ b/test-suite/success/vm_univ_poly_match.v @@ -0,0 +1,28 @@ +Set Dump Bytecode. +Set Printing Universes. +Set Printing All. + +Polymorphic Class Applicative@{d c} (T : Type@{d} -> Type@{c}) := +{ pure : forall {A : Type@{d}}, A -> T A + ; ap : forall {A B : Type@{d}}, T (A -> B) -> T A -> T B +}. + +Universes Uo Ua. + +Eval compute in @pure@{Uo Ua}. + +Global Instance Applicative_option : Applicative@{Uo Ua} option := +{| pure := @Some + ; ap := fun _ _ f x => + match f , x with + | Some f , Some x => Some (f x) + | _ , _ => None + end +|}. + +Definition foo := ap (ap (pure plus) (pure 1)) (pure 1). + +Print foo. + + +Eval vm_compute in foo. -- cgit v1.2.3 From fb77937a6ba0fe45e978911db08de57f931683e1 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 9 Dec 2015 23:38:00 +0100 Subject: Changing syntax of pat/constr1.../constrn into pat%constr1...%constrn. Marking it as experimental. --- test-suite/success/intros.v | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) (limited to 'test-suite') diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 741f372ff2..17f160f98e 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -34,47 +34,47 @@ intros _ ?. exact H. Qed. -(* A short test about introduction pattern pat/c *) +(* A short test about introduction pattern pat%c *) Goal (True -> 0=0) -> True /\ False -> 0=0. -intros H (H1/H,_). +intros H (H1%H,_). exact H1. Qed. (* A test about bugs in 8.5beta2 *) Goal (True -> 0=0) -> True /\ False -> False -> 0=0. intros H H0 H1. -destruct H0 as (a/H,_). +destruct H0 as (a%H,_). (* Check that H0 is removed (was bugged in 8.5beta2) *) Fail clear H0. -(* Check position of newly created hypotheses when using pat/c (was +(* Check position of newly created hypotheses when using pat%c (was left at top in 8.5beta2) *) match goal with H:_ |- _ => clear H end. (* clear H1:False *) match goal with H:_ |- _ => exact H end. (* check that next hyp shows 0=0 *) Qed. Goal (True -> 0=0) -> True -> 0=0. -intros H H1/H. +intros H H1%H. exact H1. Qed. Goal forall n, n = S n -> 0=0. -intros n H/n_Sn. +intros n H%n_Sn. destruct H. Qed. (* Another check about generated names and cleared hypotheses with - pat/c patterns *) + pat%c patterns *) Goal (True -> 0=0 /\ 1=1) -> True -> 0=0. -intros H (H1,?)/H. +intros H (H1,?)%H. change (1=1) in H0. exact H1. Qed. -(* Checking iterated pat/c1.../cn introduction patterns and side conditions *) +(* Checking iterated pat%c1...%cn introduction patterns and side conditions *) Goal forall A B C D:Prop, (A -> B -> C) -> (C -> D) -> B -> A -> D. intros * H H0 H1. -intros H2/H/H0. +intros H2%H%H0. - exact H2. - exact H1. Qed. -- cgit v1.2.3 From cdaf8e2ed109bd117da2366a279fa575d7b6185a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 10 Dec 2015 19:14:19 +0100 Subject: Fixing a pat%constr bug. Thanks to Enrico for reporting. --- test-suite/success/intros.v | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 17f160f98e..11156aa0ee 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -78,3 +78,9 @@ intros H2%H%H0. - exact H2. - exact H1. Qed. + +(* Bug found by Enrico *) + +Goal forall x : nat, True. +intros y%(fun x => x). +Abort. -- cgit v1.2.3 From 3c81c6c3b595ef06e0c01e51775aa0118f44e421 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 11 Dec 2015 17:59:42 +0100 Subject: Univs: Fix bug #4363, nested abstract. --- test-suite/bugs/closed/4363.v | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 test-suite/bugs/closed/4363.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4363.v b/test-suite/bugs/closed/4363.v new file mode 100644 index 0000000000..75a9c9a041 --- /dev/null +++ b/test-suite/bugs/closed/4363.v @@ -0,0 +1,7 @@ +Set Printing Universes. +Definition foo : Type. +Proof. + assert (H : Set) by abstract (assert Type by abstract exact Type using bar; exact nat). + exact bar. +Defined. (* Toplevel input, characters 0-8: +Error: \ No newline at end of file -- cgit v1.2.3 From 9329cb508f336b48a2bf2e699886546158b6b4d8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Mon, 14 Dec 2015 11:14:45 +0100 Subject: Test file for #4363 was not complete. --- test-suite/bugs/closed/4363.v | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4363.v b/test-suite/bugs/closed/4363.v index 75a9c9a041..9895548c1d 100644 --- a/test-suite/bugs/closed/4363.v +++ b/test-suite/bugs/closed/4363.v @@ -4,4 +4,6 @@ Proof. assert (H : Set) by abstract (assert Type by abstract exact Type using bar; exact nat). exact bar. Defined. (* Toplevel input, characters 0-8: -Error: \ No newline at end of file +Error: +The term "(fun _ : Set => bar) foo_subproof" has type +"Type@{Top.2}" while it is expected to have type "Type@{Top.1}". *) -- cgit v1.2.3 From 6ab322a9b0725aaa9fa6f457db061f2635598fe9 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 20:13:45 +0100 Subject: A test file for Extraction Implicit (including bugs #4243 and #4228) --- test-suite/success/extraction_impl.v | 82 ++++++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) create mode 100644 test-suite/success/extraction_impl.v (limited to 'test-suite') diff --git a/test-suite/success/extraction_impl.v b/test-suite/success/extraction_impl.v new file mode 100644 index 0000000000..a72715f292 --- /dev/null +++ b/test-suite/success/extraction_impl.v @@ -0,0 +1,82 @@ + +(** Examples of extraction with manually-declared implicit arguments *) + +(** NB: we should someday check the produced code instead of + simply running the commands. *) + +(** Bug #4243, part 1 *) + +Inductive dnat : nat -> Type := +| d0 : dnat 0 +| ds : forall n m, n = m -> dnat n -> dnat (S n). + +Extraction Implicit ds [m]. + +Lemma dnat_nat: forall n, dnat n -> nat. +Proof. + intros n d. + induction d as [| n m Heq d IHn]. + exact 0. exact (S IHn). +Defined. + +Recursive Extraction dnat_nat. + +Extraction Implicit dnat_nat [n]. +Recursive Extraction dnat_nat. + +(** Same, with a Fixpoint *) + +Fixpoint dnat_nat' n (d:dnat n) := + match d with + | d0 => 0 + | ds n m _ d => S (dnat_nat' n d) + end. + +Recursive Extraction dnat_nat'. + +Extraction Implicit dnat_nat' [n]. +Recursive Extraction dnat_nat'. + +(** Bug #4243, part 2 *) + +Inductive enat: nat -> Type := + e0: enat 0 +| es: forall n, enat n -> enat (S n). + +Lemma enat_nat: forall n, enat n -> nat. +Proof. + intros n e. + induction e as [| n e IHe]. + exact (O). + exact (S IHe). +Defined. + +Extraction Implicit es [n]. +Extraction Implicit enat_nat [n]. +Recursive Extraction enat_nat. + +(** Same, with a Fixpoint *) + +Fixpoint enat_nat' n (e:enat n) : nat := + match e with + | e0 => 0 + | es n e => S (enat_nat' n e) + end. + +Extraction Implicit enat_nat' [n]. +Recursive Extraction enat_nat. + +(** Bug #4228 *) + +Module Food. +Inductive Course := +| main: nat -> Course +| dessert: nat -> Course. + +Inductive Meal : Course -> Type := +| one_course : forall n:nat, Meal (main n) +| two_course : forall n m, Meal (main n) -> Meal (dessert m). +Extraction Implicit two_course [n]. +End Food. + +Recursive Extraction Food.Meal. -- cgit v1.2.3 From c3aa4c065fac0e37d67ca001aec47b1c2138e648 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 14 Dec 2015 20:29:45 +0100 Subject: extraction_impl.v: fix a typo --- test-suite/success/extraction_impl.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/success/extraction_impl.v b/test-suite/success/extraction_impl.v index a72715f292..dfdeff82ff 100644 --- a/test-suite/success/extraction_impl.v +++ b/test-suite/success/extraction_impl.v @@ -64,7 +64,7 @@ Fixpoint enat_nat' n (e:enat n) : nat := end. Extraction Implicit enat_nat' [n]. -Recursive Extraction enat_nat. +Recursive Extraction enat_nat'. (** Bug #4228 *) -- cgit v1.2.3 From cedcfc9bc386456f3fdd225f739706e4f7a2902c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Dec 2015 10:51:08 +0100 Subject: Refine tactic now shelves unifiable holes. The unshelve tactical can be used to get the shelved holes. This changes the proper ordering of holes though, so expect some broken scripts. Also, the test-suite is not fixed yet. --- test-suite/bugs/closed/3685.v | 4 ++-- test-suite/bugs/closed/3686.v | 4 ++-- test-suite/bugs/closed/3699.v | 16 ++++++++-------- 3 files changed, 12 insertions(+), 12 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3685.v b/test-suite/bugs/closed/3685.v index a5bea34a98..7a0c3e6f1d 100644 --- a/test-suite/bugs/closed/3685.v +++ b/test-suite/bugs/closed/3685.v @@ -39,11 +39,11 @@ Module Export PointwiseCore. (G : Functor D D') : Functor (C -> D) (C' -> D'). Proof. - refine (Build_Functor + unshelve (refine (Build_Functor (C -> D) (C' -> D') _ _ - _); + _)); abstract admit. Defined. End PointwiseCore. diff --git a/test-suite/bugs/closed/3686.v b/test-suite/bugs/closed/3686.v index b650920b26..df5f667480 100644 --- a/test-suite/bugs/closed/3686.v +++ b/test-suite/bugs/closed/3686.v @@ -33,11 +33,11 @@ Module Export PointwiseCore. (G : Functor D D') : Functor (C -> D) (C' -> D'). Proof. - refine (Build_Functor + unshelve (refine (Build_Functor (C -> D) (C' -> D') _ _ - _); + _)); abstract admit. Defined. End PointwiseCore. diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v index 62137f0c06..aad0bb44d5 100644 --- a/test-suite/bugs/closed/3699.v +++ b/test-suite/bugs/closed/3699.v @@ -34,8 +34,8 @@ Module NonPrim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intro x. exact (transport P x.2 (d x.1)). Defined. @@ -47,8 +47,8 @@ Module NonPrim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intros [a p]. exact (transport P p (d a)). Defined. @@ -111,8 +111,8 @@ Module Prim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intro x. exact (transport P x.2 (d x.1)). Defined. @@ -124,8 +124,8 @@ Module Prim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intros [a p]. exact (transport P p (d a)). Defined. -- cgit v1.2.3 From a110ddfd6fc040a805de3f0ec2995b51ff301f5c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 15 Dec 2015 11:31:13 +0100 Subject: Adding a test for the unshelve tactical. --- test-suite/success/unshelve.v | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 test-suite/success/unshelve.v (limited to 'test-suite') diff --git a/test-suite/success/unshelve.v b/test-suite/success/unshelve.v new file mode 100644 index 0000000000..672222bdd6 --- /dev/null +++ b/test-suite/success/unshelve.v @@ -0,0 +1,11 @@ +Axiom F : forall (b : bool), b = true -> + forall (i : unit), i = i -> True. + +Goal True. +Proof. +unshelve (refine (F _ _ _ _)). ++ exact true. ++ exact tt. ++ exact (@eq_refl bool true). ++ exact (@eq_refl unit tt). +Qed. -- cgit v1.2.3 From 34ea06f2f31cebf00bc7620fac34d963afe6a1dc Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 15 Dec 2015 14:54:07 +0100 Subject: Fix test-suite files after change in refine tactic. Change was introduced by cedcfc9bc386456f3fdd225f739706e4f7a2902c. --- test-suite/bugs/closed/4116.v | 6 +++--- test-suite/bugs/closed/931.v | 2 +- test-suite/bugs/closed/HoTT_coq_090.v | 2 +- test-suite/success/refine.v | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4116.v b/test-suite/bugs/closed/4116.v index f808cb45e9..5932c9c56e 100644 --- a/test-suite/bugs/closed/4116.v +++ b/test-suite/bugs/closed/4116.v @@ -110,7 +110,7 @@ Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A. Tactic Notation "transparent" "assert" "(" ident(name) ":" constr(type) ")" := - refine (let __transparent_assert_hypothesis := (_ : type) in _); + unshelve refine (let __transparent_assert_hypothesis := (_ : type) in _); [ | ( let H := match goal with H := _ |- _ => constr:(H) end in @@ -321,7 +321,7 @@ Section Grothendieck. Definition Gcategory : PreCategory. Proof. - refine (@Build_PreCategory + unshelve refine (@Build_PreCategory Pair (fun s d => Gmorphism s d) Gidentity @@ -346,7 +346,7 @@ Section Grothendieck2. Instance iscategory_grothendieck_toset : IsCategory (Gcategory F). Proof. intros s d. - refine (isequiv_adjointify _ _ _ _). + unshelve refine (isequiv_adjointify _ _ _ _). { intro m. transparent assert (H' : (s.(c) = d.(c))). diff --git a/test-suite/bugs/closed/931.v b/test-suite/bugs/closed/931.v index e86b3be64e..ea3347a851 100644 --- a/test-suite/bugs/closed/931.v +++ b/test-suite/bugs/closed/931.v @@ -2,6 +2,6 @@ Parameter P : forall n : nat, n=n -> Prop. Goal Prop. refine (P _ _). - 2:instantiate (1:=0). + instantiate (1:=0). trivial. Qed. diff --git a/test-suite/bugs/closed/HoTT_coq_090.v b/test-suite/bugs/closed/HoTT_coq_090.v index 5fa167038d..d77b9b63a2 100644 --- a/test-suite/bugs/closed/HoTT_coq_090.v +++ b/test-suite/bugs/closed/HoTT_coq_090.v @@ -84,7 +84,7 @@ Arguments transport {A} P {x y} p%path_scope u : simpl nomatch. Instance isequiv_path {A B : Type} (p : A = B) : IsEquiv (transport (fun X:Type => X) p) | 0. Proof. - refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _); + unshelve refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _); admit. Defined. diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index 1e667884b8..352abb2af5 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -62,7 +62,7 @@ Abort. Goal (forall n : nat, n = 0 -> Prop) -> Prop. intro P. refine (P _ _). -2:reflexivity. +reflexivity. Abort. (* Submitted by Jacek Chrzaszcz (bug #1102) *) -- cgit v1.2.3 From 0a89d4805a29628c82b994958362dc9d92709020 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 15 Dec 2015 18:56:08 +0100 Subject: Extraction: more cautious use of intermediate result caching (fix #3923) During an extraction, a few tables are maintained to cache intermediate results. Due to modules, the kernel_name index for these caching tables aren't enough. For instance, in bug #3923, a constant is first transparent (from inside the module) then opaque (when seen from the signature). The previous protections were actually obsolete (tests via visible_con), we now checks that the constant_body is still the same. --- test-suite/bugs/closed/3923.v | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 test-suite/bugs/closed/3923.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3923.v b/test-suite/bugs/closed/3923.v new file mode 100644 index 0000000000..0aa029e73d --- /dev/null +++ b/test-suite/bugs/closed/3923.v @@ -0,0 +1,33 @@ +Module Type TRIVIAL. +Parameter t:Type. +End TRIVIAL. + +Module MkStore (Key : TRIVIAL). + +Module St : TRIVIAL. +Definition t := unit. +End St. + +End MkStore. + + + +Module Type CERTRUNTIMETYPES (B : TRIVIAL). + +Parameter cert_fieldstore : Type. +Parameter empty_fieldstore : cert_fieldstore. + +End CERTRUNTIMETYPES. + + + +Module MkCertRuntimeTypes (B : TRIVIAL) : CERTRUNTIMETYPES B. + +Module FieldStore := MkStore B. + +Definition cert_fieldstore := FieldStore.St.t. +Axiom empty_fieldstore : cert_fieldstore. + +End MkCertRuntimeTypes. + +Extraction MkCertRuntimeTypes. (* Was leading to an uncaught Not_found *) -- cgit v1.2.3 From 7212e6c4a742110138a268650a59a67ef28d0582 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 15 Dec 2015 21:15:42 +0100 Subject: Fix test suite after change in extraction. --- test-suite/output/Extraction_matchs_2413.out | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/output/Extraction_matchs_2413.out b/test-suite/output/Extraction_matchs_2413.out index 848abd0096..f738b0d091 100644 --- a/test-suite/output/Extraction_matchs_2413.out +++ b/test-suite/output/Extraction_matchs_2413.out @@ -4,7 +4,7 @@ let test1 b = b (** val test2 : bool -> bool **) -let test2 b = +let test2 _ = False (** val wrong_id : 'a1 hole -> 'a2 hole **) -- cgit v1.2.3 From 33742251e62a49c7996b96ca7077cf985627d14b Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Tue, 15 Dec 2015 23:15:02 +0100 Subject: Proof using: do not clear unused section hyps automatically The option is still there, but not documented since it is too dangerous. Hints and type classes instances are not taking cleared variables into account. --- test-suite/success/proof_using.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v index c83f45e2a4..adaa05ad06 100644 --- a/test-suite/success/proof_using.v +++ b/test-suite/success/proof_using.v @@ -178,6 +178,7 @@ End Let. Check (test_let 3). +(* Disabled Section Clear. Variable a: nat. @@ -192,6 +193,6 @@ trivial. Qed. End Clear. - +*) -- cgit v1.2.3 From 840cefca77a48ad68641539cd26d8d2e8c9dc031 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 17 Dec 2015 20:32:09 +0100 Subject: (Partial) fix for bug #4453: raise an error instead of an anomaly. --- test-suite/bugs/closed/4453.v | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 test-suite/bugs/closed/4453.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4453.v b/test-suite/bugs/closed/4453.v new file mode 100644 index 0000000000..009dd5e3ca --- /dev/null +++ b/test-suite/bugs/closed/4453.v @@ -0,0 +1,8 @@ + +Section Foo. +Variable A : Type. +Lemma foo : A -> True. now intros _. Qed. +Goal Type -> True. +rename A into B. +intros A. +Fail apply foo. -- cgit v1.2.3 From 5122a39888cfc6afd2383d59465324dd67b69f4a Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 21 Dec 2015 18:56:43 +0100 Subject: Inclusion of functors with restricted signature is now forbidden (fix #3746) The previous behavior was to include the interface of such a functor, possibly leading to the creation of unexpected axioms, see bug report #3746. In the case of non-functor module with restricted signature, we could simply refer to the original objects (strengthening), but for a functor, the inner objects have no existence yet. As said in the new error message, a simple workaround is hence to first instantiate the functor, then include the local instance: Module LocalInstance := Funct(Args). Include LocalInstance. By the way, the mod_type_alg field is now filled more systematically, cf new comments in declarations.mli. This way, we could use it to know whether a module had been given a restricted signature (via ":"). Earlier, some mod_type_alg were None in situations not handled by the extraction (MEapply of module type). Some code refactoring on the fly. --- test-suite/bugs/closed/3746.v | 92 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 92 insertions(+) create mode 100644 test-suite/bugs/closed/3746.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3746.v b/test-suite/bugs/closed/3746.v new file mode 100644 index 0000000000..a9463f94bb --- /dev/null +++ b/test-suite/bugs/closed/3746.v @@ -0,0 +1,92 @@ + +(* Bug report #3746 : Include and restricted signature *) + +Module Type MT. Parameter p : nat. End MT. +Module Type EMPTY. End EMPTY. +Module Empty. End Empty. + +(* Include of an applied functor with restricted sig : + Used to create axioms (bug report #3746), now forbidden. *) + +Module F (X:EMPTY) : MT. + Definition p := 0. +End F. + +Module InclFunctRestr. + Fail Include F(Empty). +End InclFunctRestr. + +(* A few variants (indirect restricted signature), also forbidden. *) + +Module F1 := F. +Module F2 (X:EMPTY) := F X. + +Module F3a (X:EMPTY). Definition p := 0. End F3a. +Module F3 (X:EMPTY) : MT := F3a X. + +Module InclFunctRestrBis. + Fail Include F1(Empty). + Fail Include F2(Empty). + Fail Include F3(Empty). +End InclFunctRestrBis. + +(* Recommended workaround: manual instance before the include. *) + +Module InclWorkaround. + Module Temp := F(Empty). + Include Temp. +End InclWorkaround. + +Compute InclWorkaround.p. +Print InclWorkaround.p. +Print Assumptions InclWorkaround.p. (* Closed under the global context *) + + + +(* Related situations which are ok, just to check *) + +(* A) Include of non-functor with restricted signature : + creates a proxy to initial stuff *) + +Module M : MT. + Definition p := 0. +End M. + +Module InclNonFunct. + Include M. +End InclNonFunct. + +Definition check : InclNonFunct.p = M.p := eq_refl. +Print Assumptions InclNonFunct.p. (* Closed *) + + +(* B) Include of a module type with opaque content: + The opaque content is "copy-pasted". *) + +Module Type SigOpaque. + Definition p : nat. Proof. exact 0. Qed. +End SigOpaque. + +Module InclSigOpaque. + Include SigOpaque. +End InclSigOpaque. + +Compute InclSigOpaque.p. +Print InclSigOpaque.p. +Print Assumptions InclSigOpaque.p. (* Closed *) + + +(* C) Include of an applied functor with opaque proofs : + opaque proof "copy-pasted" (and substituted). *) + +Module F' (X:EMPTY). + Definition p : nat. Proof. exact 0. Qed. +End F'. + +Module InclFunctOpa. + Include F'(Empty). +End InclFunctOpa. + +Compute InclFunctOpa.p. +Print InclFunctOpa.p. +Print Assumptions InclFunctOpa.p. (* Closed *) -- cgit v1.2.3 From c3e01a044297d322d8a5e6830fe3af002ebd2dce Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 18 Dec 2015 08:23:35 +0100 Subject: Fixing an "injection as" bug in the presence of side conditions. --- test-suite/success/Injection.v | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v index 25e464d677..8fd0394625 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -68,6 +68,12 @@ einjection (H O). instantiate (1:=O). Abort. +Goal (forall x y : nat, x = y -> S x = S y) -> True. +intros. +einjection (H O) as H0. +instantiate (y:=O). +Abort. + (* Test the injection intropattern *) Goal forall (a b:nat) l l', cons a l = cons b l' -> a=b. -- cgit v1.2.3 From df9d69f3ccf3e5600919a21112afda00b463fbc5 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 18 Dec 2015 19:38:19 +0100 Subject: Fixing a bug in the order of side conditions for introduction pattern -> and <-. --- test-suite/success/intros.v | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 11156aa0ee..69d66f1008 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -84,3 +84,17 @@ Qed. Goal forall x : nat, True. intros y%(fun x => x). Abort. + +(* Fixing a bug in the order of side conditions of a "->" step *) + +Goal (True -> 1=0) -> 1=1. +intros ->. +- reflexivity. +- exact I. +Qed. + +Goal forall x, (True -> x=0) -> 0=x. +intros x ->. +- reflexivity. +- exact I. +Qed. -- cgit v1.2.3 From b2eaecf0e748e3c286e1ef337f72cee6d3475162 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Dec 2015 02:48:45 +0100 Subject: Fixing bug #4462: unshelve: Anomaly: Uncaught exception Not_found. The rewrite tactic was causing an evar leak because of the use of the Evd.remove primitive. This function did not modify the future goals of the evarmap to remove the considered evar and thus maintained dangling evars in there, causing the anomaly. --- test-suite/bugs/closed/4462.v | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 test-suite/bugs/closed/4462.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4462.v b/test-suite/bugs/closed/4462.v new file mode 100644 index 0000000000..c680518c6a --- /dev/null +++ b/test-suite/bugs/closed/4462.v @@ -0,0 +1,7 @@ +Variables P Q : Prop. +Axiom pqrw : P <-> Q. + +Require Setoid. + +Goal P -> Q. +unshelve (rewrite pqrw). -- cgit v1.2.3 From 203b0eaac832af3b62e484c1aef89a02ffe8e29b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Dec 2015 18:31:17 +0100 Subject: External tactics and notations now accept any tactic argument. This commit has deep consequences in term of tactic evaluation, as it allows to pass any tac_arg to ML and alias tactics rather than mere generic arguments. This makes the evaluation much more uniform, and in particular it removes the special evaluation function for notations. This last point may break some notations out there unluckily. I had to treat in an ad-hoc way the tactic(...) entry of tactic notations because it is actually not interpreted as a generic argument but rather as a proper tactic expression instead. There is for now no syntax to pass any tactic argument to a given ML or notation tactic, but this should come soon. Also fixes bug #3849 en passant. --- test-suite/bugs/closed/3849.v | 8 ++++++++ test-suite/bugs/opened/3849.v | 8 -------- 2 files changed, 8 insertions(+), 8 deletions(-) create mode 100644 test-suite/bugs/closed/3849.v delete mode 100644 test-suite/bugs/opened/3849.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3849.v b/test-suite/bugs/closed/3849.v new file mode 100644 index 0000000000..a8dc3af9cf --- /dev/null +++ b/test-suite/bugs/closed/3849.v @@ -0,0 +1,8 @@ +Tactic Notation "foo" hyp_list(hs) := clear hs. + +Tactic Notation "bar" hyp_list(hs) := foo hs. + +Goal True. +do 5 pose proof 0 as ?n0. +foo n1 n2. +bar n3 n4. diff --git a/test-suite/bugs/opened/3849.v b/test-suite/bugs/opened/3849.v deleted file mode 100644 index 5290054a06..0000000000 --- a/test-suite/bugs/opened/3849.v +++ /dev/null @@ -1,8 +0,0 @@ -Tactic Notation "foo" hyp_list(hs) := clear hs. - -Tactic Notation "bar" hyp_list(hs) := foo hs. - -Goal True. -do 5 pose proof 0 as ?n0. -foo n1 n2. -Fail bar n3 n4. -- cgit v1.2.3 From a1d6232019dd903419b0ac10819dfde6759c45d1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 31 Dec 2015 19:32:31 +0100 Subject: Fix bug #4456, anomaly in handle-side effects The side-effects can contain universe declarations needed to typecheck later proofs, which weren't added to the env used to typecheck them. --- test-suite/bugs/closed/4456.v | 647 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 647 insertions(+) create mode 100644 test-suite/bugs/closed/4456.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4456.v b/test-suite/bugs/closed/4456.v new file mode 100644 index 0000000000..a32acf789c --- /dev/null +++ b/test-suite/bugs/closed/4456.v @@ -0,0 +1,647 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "." "Fiat" "-top" "BooleanRecognizerMin" "-R" "." "Top") -*- *) +(* File reduced by coq-bug-finder from original input, then from 2475 lines to 729 lines, then from 746 lines to 658 lines, then from 675 lines to 658 lines *) +(* coqc version 8.5beta3 (November 2015) compiled on Nov 11 2015 18:23:0 with OCaml 4.01.0 + coqtop version 8.5beta3 (November 2015) *) +(* Variable P : forall n m : nat, n = m -> Prop. *) +(* Axiom Prefl : forall n : nat, P n n eq_refl. *) +Axiom proof_admitted : False. + +Tactic Notation "admit" := case proof_admitted. + +Require Coq.Program.Program. +Require Coq.Strings.String. +Require Coq.omega.Omega. +Module Export Fiat_DOT_Common. +Module Export Fiat. +Module Common. +Import Coq.Lists.List. +Export Coq.Program.Program. + +Global Set Implicit Arguments. + +Global Coercion is_true : bool >-> Sortclass. +Coercion bool_of_sum {A B} (b : sum A B) : bool := if b then true else false. + +Fixpoint ForallT {T} (P : T -> Type) (ls : list T) : Type + := match ls return Type with + | nil => True + | x::xs => (P x * ForallT P xs)%type + end. +Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type + := match ls with + | nil => P nil + | x::xs => (P (x::xs) * Forall_tails P xs)%type + end. + +End Common. + +End Fiat. + +End Fiat_DOT_Common. +Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. +Module Export Fiat. +Module Export Parsers. +Module Export StringLike. +Module Export Core. +Import Coq.Relations.Relation_Definitions. +Import Coq.Classes.Morphisms. + +Local Coercion is_true : bool >-> Sortclass. + +Module Export StringLike. + Class StringLike {Char : Type} := + { + String :> Type; + is_char : String -> Char -> bool; + length : String -> nat; + take : nat -> String -> String; + drop : nat -> String -> String; + get : nat -> String -> option Char; + unsafe_get : nat -> String -> Char; + bool_eq : String -> String -> bool; + beq : relation String := fun x y => bool_eq x y + }. + + Arguments StringLike : clear implicits. + Infix "=s" := (@beq _ _) (at level 70, no associativity) : type_scope. + Notation "s ~= [ ch ]" := (is_char s ch) (at level 70, no associativity) : string_like_scope. + Local Open Scope string_like_scope. + + Class StringLikeProperties (Char : Type) `{StringLike Char} := + { + singleton_unique : forall s ch ch', s ~= [ ch ] -> s ~= [ ch' ] -> ch = ch'; + singleton_exists : forall s, length s = 1 -> exists ch, s ~= [ ch ]; + get_0 : forall s ch, take 1 s ~= [ ch ] <-> get 0 s = Some ch; + get_S : forall n s, get (S n) s = get n (drop 1 s); + unsafe_get_correct : forall n s ch, get n s = Some ch -> unsafe_get n s = ch; + length_singleton : forall s ch, s ~= [ ch ] -> length s = 1; + bool_eq_char : forall s s' ch, s ~= [ ch ] -> s' ~= [ ch ] -> s =s s'; + is_char_Proper :> Proper (beq ==> eq ==> eq) is_char; + length_Proper :> Proper (beq ==> eq) length; + take_Proper :> Proper (eq ==> beq ==> beq) take; + drop_Proper :> Proper (eq ==> beq ==> beq) drop; + bool_eq_Equivalence :> Equivalence beq; + bool_eq_empty : forall str str', length str = 0 -> length str' = 0 -> str =s str'; + take_short_length : forall str n, n <= length str -> length (take n str) = n; + take_long : forall str n, length str <= n -> take n str =s str; + take_take : forall str n m, take n (take m str) =s take (min n m) str; + drop_length : forall str n, length (drop n str) = length str - n; + drop_0 : forall str, drop 0 str =s str; + drop_drop : forall str n m, drop n (drop m str) =s drop (n + m) str; + drop_take : forall str n m, drop n (take m str) =s take (m - n) (drop n str); + take_drop : forall str n m, take n (drop m str) =s drop m (take (n + m) str); + bool_eq_from_get : forall str str', (forall n, get n str = get n str') -> str =s str' + }. +Global Arguments StringLikeProperties _ {_}. +End StringLike. + +End Core. + +End StringLike. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. + +Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Core. +Import Coq.Strings.String. +Import Coq.Lists.List. +Export Fiat.Parsers.StringLike.Core. + +Section cfg. + Context {Char : Type}. + + Section definitions. + + Inductive item := + | Terminal (_ : Char) + | NonTerminal (_ : string). + + Definition production := list item. + Definition productions := list production. + + Record grammar := + { + Start_symbol :> string; + Lookup :> string -> productions; + Start_productions :> productions := Lookup Start_symbol; + Valid_nonterminals : list string; + Valid_productions : list productions := map Lookup Valid_nonterminals + }. + End definitions. + + End cfg. + +Arguments item _ : clear implicits. +Arguments production _ : clear implicits. +Arguments productions _ : clear implicits. +Arguments grammar _ : clear implicits. + +End Core. + +End ContextFreeGrammar. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. + +Module Export Fiat_DOT_Parsers_DOT_BaseTypes. +Module Export Fiat. +Module Export Parsers. +Module Export BaseTypes. +Import Coq.Arith.Wf_nat. + +Local Coercion is_true : bool >-> Sortclass. + +Section recursive_descent_parser. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + + Class parser_computational_predataT := + { nonterminals_listT : Type; + nonterminal_carrierT : Type; + of_nonterminal : String.string -> nonterminal_carrierT; + to_nonterminal : nonterminal_carrierT -> String.string; + initial_nonterminals_data : nonterminals_listT; + nonterminals_length : nonterminals_listT -> nat; + is_valid_nonterminal : nonterminals_listT -> nonterminal_carrierT -> bool; + remove_nonterminal : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT }. + + Class parser_removal_dataT' `{predata : parser_computational_predataT} := + { nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop + := ltof _ nonterminals_length; + nonterminals_length_zero : forall ls, + nonterminals_length ls = 0 + -> forall nt, is_valid_nonterminal ls nt = false; + remove_nonterminal_dec : forall ls nonterminal, + is_valid_nonterminal ls nonterminal + -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; + remove_nonterminal_noninc : forall ls nonterminal, + ~nonterminals_listT_R ls (remove_nonterminal ls nonterminal); + initial_nonterminals_correct : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) <-> List.In nonterminal (Valid_nonterminals G); + initial_nonterminals_correct' : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data nonterminal <-> List.In (to_nonterminal nonterminal) (Valid_nonterminals G); + to_of_nonterminal : forall nonterminal, + List.In nonterminal (Valid_nonterminals G) + -> to_nonterminal (of_nonterminal nonterminal) = nonterminal; + of_to_nonterminal : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data nonterminal + -> of_nonterminal (to_nonterminal nonterminal) = nonterminal; + ntl_wf : well_founded nonterminals_listT_R + := well_founded_ltof _ _; + remove_nonterminal_1 + : forall ls ps ps', + is_valid_nonterminal (remove_nonterminal ls ps) ps' + -> is_valid_nonterminal ls ps'; + remove_nonterminal_2 + : forall ls ps ps', + is_valid_nonterminal (remove_nonterminal ls ps) ps' = false + <-> is_valid_nonterminal ls ps' = false \/ ps = ps' }. + + Class split_dataT := + { split_string_for_production + : item Char -> production Char -> String -> list nat }. + + Class boolean_parser_dataT := + { predata :> parser_computational_predataT; + split_data :> split_dataT }. +End recursive_descent_parser. + +End BaseTypes. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_BaseTypes. + +Module Export Fiat_DOT_Common_DOT_List_DOT_Operations. +Module Export Fiat. +Module Export Common. +Module Export List. +Module Export Operations. + +Import Coq.Lists.List. + +Module Export List. + Section InT. + Context {A : Type} (a : A). + + Fixpoint InT (ls : list A) : Set + := match ls return Set with + | nil => False + | b :: m => (b = a) + InT m + end%type. + End InT. + + End List. + +End Operations. + +End List. + +End Common. + +End Fiat. + +End Fiat_DOT_Common_DOT_List_DOT_Operations. + +Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. +Module Export Fiat. +Module Export Parsers. +Module Export StringLike. +Module Export Properties. + +Section String. + Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}. + + Lemma take_length {str n} + : length (take n str) = min n (length str). +admit. +Defined. + + End String. + +End Properties. + +End StringLike. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. + +Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Properties. + +Local Open Scope list_scope. +Definition production_is_reachableT {Char} (G : grammar Char) (p : production Char) + := { nt : _ + & { prefix : _ + & List.In nt (Valid_nonterminals G) + * List.InT + (prefix ++ p) + (Lookup G nt) } }%type. + +End Properties. + +End ContextFreeGrammar. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. + +Module Export Fiat_DOT_Parsers_DOT_MinimalParse. +Module Export Fiat. +Module Export Parsers. +Module Export MinimalParse. +Import Coq.Lists.List. +Import Fiat.Parsers.ContextFreeGrammar.Core. + +Local Coercion is_true : bool >-> Sortclass. +Local Open Scope string_like_scope. + +Section cfg. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + Context {predata : @parser_computational_predataT} + {rdata' : @parser_removal_dataT' _ G predata}. + + Inductive minimal_parse_of + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + productions Char -> Type := + | MinParseHead : forall len0 valid str pat pats, + @minimal_parse_of_production len0 valid str pat + -> @minimal_parse_of len0 valid str (pat::pats) + | MinParseTail : forall len0 valid str pat pats, + @minimal_parse_of len0 valid str pats + -> @minimal_parse_of len0 valid str (pat::pats) + with minimal_parse_of_production + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + production Char -> Type := + | MinParseProductionNil : forall len0 valid str, + length str = 0 + -> @minimal_parse_of_production len0 valid str nil + | MinParseProductionCons : forall len0 valid str n pat pats, + length str <= len0 + -> @minimal_parse_of_item len0 valid (take n str) pat + -> @minimal_parse_of_production len0 valid (drop n str) pats + -> @minimal_parse_of_production len0 valid str (pat::pats) + with minimal_parse_of_item + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + item Char -> Type := + | MinParseTerminal : forall len0 valid str ch, + str ~= [ ch ] + -> @minimal_parse_of_item len0 valid str (Terminal ch) + | MinParseNonTerminal + : forall len0 valid str (nt : String.string), + @minimal_parse_of_nonterminal len0 valid str nt + -> @minimal_parse_of_item len0 valid str (NonTerminal nt) + with minimal_parse_of_nonterminal + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + String.string -> Type := + | MinParseNonTerminalStrLt + : forall len0 valid (nt : String.string) str, + length str < len0 + -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) + -> @minimal_parse_of (length str) initial_nonterminals_data str (Lookup G nt) + -> @minimal_parse_of_nonterminal len0 valid str nt + | MinParseNonTerminalStrEq + : forall len0 str valid nonterminal, + length str = len0 + -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) + -> is_valid_nonterminal valid (of_nonterminal nonterminal) + -> @minimal_parse_of len0 (remove_nonterminal valid (of_nonterminal nonterminal)) str (Lookup G nonterminal) + -> @minimal_parse_of_nonterminal len0 valid str nonterminal. + +End cfg. + +End MinimalParse. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_MinimalParse. + +Module Export Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. +Module Export Fiat. +Module Export Parsers. +Module Export CorrectnessBaseTypes. +Import Coq.Lists.List. +Import Fiat.Parsers.ContextFreeGrammar.Core. +Import Fiat_DOT_Common.Fiat.Common. +Section general. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + + Definition split_list_completeT_for {data : @parser_computational_predataT} + {len0 valid} + (it : item Char) (its : production Char) + (str : String) + (pf : length str <= len0) + (split_list : list nat) + + := ({ n : nat + & (minimal_parse_of_item (G := G) (predata := data) len0 valid (take n str) it) + * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type) + -> ({ n : nat + & (In (min (length str) n) (map (min (length str)) split_list)) + * (minimal_parse_of_item (G := G) len0 valid (take n str) it) + * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type). + + Definition split_list_completeT {data : @parser_computational_predataT} + (splits : item Char -> production Char -> String -> list nat) + := forall len0 valid str (pf : length str <= len0) nt, + is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) + -> ForallT + (Forall_tails + (fun prod + => match prod return Type with + | nil => True + | it::its + => @split_list_completeT_for data len0 valid it its str pf (splits it its str) + end)) + (Lookup G nt). + + Class boolean_parser_completeness_dataT' {data : boolean_parser_dataT} := + { split_string_for_production_complete + : split_list_completeT split_string_for_production }. +End general. + +End CorrectnessBaseTypes. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. + +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Valid. +Export Fiat.Parsers.StringLike.Core. + +Section cfg. + Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) + {predata : parser_computational_predataT}. + + Definition item_valid (it : item Char) + := match it with + | Terminal _ => True + | NonTerminal nt' => is_true (is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt')) + end. + + Definition production_valid pat + := List.Forall item_valid pat. + + Definition productions_valid pats + := List.Forall production_valid pats. + + Definition grammar_valid + := forall nt, + List.In nt (Valid_nonterminals G) + -> productions_valid (Lookup G nt). +End cfg. + +End Valid. + +Section app. + Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) + {predata : parser_computational_predataT}. + + Lemma hd_production_valid + (it : item Char) + (its : production Char) + (H : production_valid (it :: its)) + : item_valid it. +admit. +Defined. + + Lemma production_valid_cons + (it : item Char) + (its : production Char) + (H : production_valid (it :: its)) + : production_valid its. +admit. +Defined. + + End app. + +Import Coq.Lists.List. +Import Coq.omega.Omega. +Import Fiat_DOT_Common.Fiat.Common. +Import Fiat.Parsers.ContextFreeGrammar.Valid. +Local Open Scope string_like_scope. + +Section recursive_descent_parser. + Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char). + Context {data : @boolean_parser_dataT Char _} + {cdata : @boolean_parser_completeness_dataT' Char _ G data} + {rdata : @parser_removal_dataT' _ G _} + {gvalid : grammar_valid G}. + + Local Notation dec T := (T + (T -> False))%type (only parsing). + + Local Notation iffT x y := ((x -> y) * (y -> x))%type (only parsing). + + Lemma dec_prod {A B} (HA : dec A) (HB : dec B) : dec (A * B). +admit. +Defined. + + Lemma dec_In {A} {P : A -> Type} (HA : forall a, dec (P a)) ls + : dec { a : _ & (In a ls * P a) }. +admit. +Defined. + + Section item. + Context {len0 valid} + (str : String) + (str_matches_nonterminal' + : nonterminal_carrierT -> bool) + (str_matches_nonterminal + : forall nt : nonterminal_carrierT, + dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). + + Section valid. + Context (Hmatches + : forall nt, + is_valid_nonterminal initial_nonterminals_data nt + -> str_matches_nonterminal nt = str_matches_nonterminal' nt :> bool) + (it : item Char) + (Hvalid : item_valid it). + + Definition parse_item' + : dec (minimal_parse_of_item (G := G) len0 valid str it). + Proof. + clear Hvalid. + refine (match it return dec (minimal_parse_of_item len0 valid str it) with + | Terminal ch => if Sumbool.sumbool_of_bool (str ~= [ ch ]) + then inl (MinParseTerminal _ _ _ _ _) + else inr (fun _ => !) + | NonTerminal nt => if str_matches_nonterminal (of_nonterminal nt) + then inl (MinParseNonTerminal _) + else inr (fun _ => !) + end); + clear str_matches_nonterminal Hmatches; + admit. + Defined. + End valid. + + End item. + Context {len0 valid} + (parse_nonterminal + : forall (str : String) (len : nat) (Hlen : length str = len) (pf : len <= len0) (nt : nonterminal_carrierT), + dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). + + Lemma dec_in_helper {ls it its str} + : iffT {n0 : nat & + (In (min (length str) n0) (map (min (length str)) ls) * + minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} + {n0 : nat & + (In n0 ls * + (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its))%type}. +admit. +Defined. + + Lemma parse_production'_helper {str it its} (pf : length str <= len0) + : dec {n0 : nat & + (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} + -> dec (minimal_parse_of_production (G := G) len0 valid str (it :: its)). +admit. +Defined. + Local Ltac t_parse_production_for := repeat + match goal with + | [ H : (beq_nat _ _) = true |- _ ] => apply EqNat.beq_nat_true in H + | _ => progress subst + | _ => solve [ constructor; assumption ] + | [ H : minimal_parse_of_production _ _ _ nil |- _ ] => (inversion H; clear H) + | [ H : minimal_parse_of_production _ _ _ (_::_) |- _ ] => (inversion H; clear H) + | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H' + | _ => progress simpl in * + | _ => discriminate + | [ H : forall x, (_ * _)%type -> _ |- _ ] => specialize (fun x y z => H x (y, z)) + | _ => solve [ eauto with nocore ] + | _ => solve [ apply Min.min_case_strong; omega ] + | _ => omega + | [ H : production_valid (_::_) |- _ ] + => let H' := fresh in + pose proof H as H'; + apply production_valid_cons in H; + apply hd_production_valid in H' + end. + + Definition parse_production'_for + (splits : item Char -> production Char -> String -> list nat) + (Hsplits : forall str it its (Hreachable : production_is_reachableT G (it::its)) pf', split_list_completeT_for (len0 := len0) (G := G) (valid := valid) it its str pf' (splits it its str)) + (str : String) + (len : nat) + (Hlen : length str = len) + (pf : len <= len0) + (prod : production Char) + (Hreachable : production_is_reachableT G prod) + : dec (minimal_parse_of_production (G := G) len0 valid str prod). + Proof. + revert prod Hreachable str len Hlen pf. + refine + ((fun pf_helper => + list_rect + (fun prod => + forall (Hreachable : production_is_reachableT G prod) + (str : String) + (len : nat) + (Hlen : length str = len) + (pf : len <= len0), + dec (minimal_parse_of_production (G := G) len0 valid str prod)) + ( + fun Hreachable str len Hlen pf + => match Utils.dec (beq_nat len 0) with + | left H => inl _ + | right H => inr (fun p => _) + end) + (fun it its parse_production' Hreachable str len Hlen pf + => parse_production'_helper + _ + (let parse_item := (fun n pf => parse_item' (parse_nonterminal (take n str) (len := min n len) (eq_trans take_length (f_equal (min _) Hlen)) pf) it) in + let parse_item := (fun n => parse_item n (Min.min_case_strong n len (fun k => k <= len0) (fun Hlen => (Nat.le_trans _ _ _ Hlen pf)) (fun Hlen => pf))) in + let parse_production := (fun n => parse_production' (pf_helper it its Hreachable) (drop n str) (len - n) (eq_trans (drop_length _ _) (f_equal (fun x => x - _) Hlen)) (Nat.le_trans _ _ _ (Nat.le_sub_l _ _) pf)) in + match dec_In + (fun n => dec_prod (parse_item n) (parse_production n)) + (splits it its str) + with + | inl p => inl (existT _ (projT1 p) (snd (projT2 p))) + | inr p + => let pf' := (Nat.le_trans _ _ _ (Nat.eq_le_incl _ _ Hlen) pf) in + let H := (_ : split_list_completeT_for (G := G) (len0 := len0) (valid := valid) it its str pf' (splits it its str)) in + inr (fun p' => p (fst dec_in_helper (H p'))) + end) + )) _); + [ clear parse_nonterminal Hsplits splits rdata cdata + | clear parse_nonterminal Hsplits splits rdata cdata + | .. + | admit ]. + abstract t_parse_production_for. + abstract t_parse_production_for. + abstract t_parse_production_for. + abstract t_parse_production_for. + Defined. -- cgit v1.2.3 From 37cc37090fcbabb9546a79558c9420e532701be4 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 31 Dec 2015 20:07:06 +0100 Subject: Put implicits back as in 8.4. --- test-suite/bugs/closed/3743.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3743.v b/test-suite/bugs/closed/3743.v index 4dfb3380a8..c799d4393f 100644 --- a/test-suite/bugs/closed/3743.v +++ b/test-suite/bugs/closed/3743.v @@ -3,7 +3,7 @@ coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d65496f09c4b68fa318783e53f9cd6d5c18e1eb7) *) Require Export Coq.Setoids.Setoid. -Fail Add Parametric Relation A +Add Parametric Relation A : A (@eq A) transitivity proved by transitivity as refine_rel. -- cgit v1.2.3 From e309d8119cd82bdf1216751fb076d438782fb60f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 7 Jan 2016 17:20:51 +0100 Subject: Fix bug #4480: progress was not checked for setoid_rewrite. Also ensure we stay compatible with 8.4: progress could now be made simply because of beta redexes in the goal. --- test-suite/bugs/closed/4480.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 test-suite/bugs/closed/4480.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4480.v b/test-suite/bugs/closed/4480.v new file mode 100644 index 0000000000..08a86330f2 --- /dev/null +++ b/test-suite/bugs/closed/4480.v @@ -0,0 +1,12 @@ +Require Import Setoid. + +Definition proj (P Q : Prop) := P. + +Lemma foo (P : Prop) : proj P P = P. +Admitted. +Lemma trueI : True <-> True. +Admitted. +Goal True. + Fail setoid_rewrite foo. + Fail setoid_rewrite trueI. + \ No newline at end of file -- cgit v1.2.3 From 730e8b8445c6ff28540aff4a052e19b90159a86d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 9 Jan 2016 17:10:36 +0100 Subject: Fix bug 4479: "Error: Rewriting base foo does not exist." should be catchable. --- test-suite/bugs/closed/4479.v | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 test-suite/bugs/closed/4479.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4479.v b/test-suite/bugs/closed/4479.v new file mode 100644 index 0000000000..921579d1e1 --- /dev/null +++ b/test-suite/bugs/closed/4479.v @@ -0,0 +1,3 @@ +Goal True. +Fail autorewrite with foo. +try autorewrite with foo. -- cgit v1.2.3 From eb40037b4c341746933c713e8950f3a60d550f4a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 12 Jan 2016 17:32:04 +0100 Subject: Extend Keyed Unification tests with the one from R. Krebbers. --- test-suite/success/keyedrewrite.v | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index bbe9d4bfff..d1a93581ca 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -22,3 +22,34 @@ Qed. Print Equivalent Keys. End foo. + +Require Import Arith List Omega. + +Definition G {A} (f : A -> A -> A) (x : A) := f x x. + +Lemma list_foo A (l : list A) : G (@app A) (l ++ nil) = G (@app A) l. +Proof. unfold G; rewrite app_nil_r; reflexivity. Qed. + +(* Bundled version of a magma *) +Structure magma := Magma { b_car :> Type; op : b_car -> b_car -> b_car }. +Arguments op {_} _ _. + +(* Instance for lists *) +Canonical Structure list_magma A := Magma (list A) (@app A). + +(* Basically like list_foo, but now uses the op projection instead of app for +the argument of G *) +Lemma test1 A (l : list A) : G op (l ++ nil) = G op l. + +(* Ensure that conversion of terms with evars is allowed once a keyed candidate unifier is found *) +rewrite -> list_foo. +reflexivity. +Qed. + +(* Basically like list_foo, but now uses the op projection for everything *) +Lemma test2 A (l : list A) : G op (op l nil) = G op l. +Proof. +rewrite ->list_foo. +reflexivity. +Qed. + -- cgit v1.2.3 From fc642ca962dd5228a5a714b8e41506dcbc3b6520 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 12 Jan 2016 19:27:02 +0100 Subject: Extend last commit: keyed unification uses full conversions on the applied constant and arguments _separately_. --- test-suite/success/keyedrewrite.v | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index d1a93581ca..5b0502cf1a 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -53,3 +53,9 @@ rewrite ->list_foo. reflexivity. Qed. + Require Import Bool. + Set Keyed Unification. + + Lemma test b : b && true = b. + Fail rewrite andb_true_l. + Admitted. \ No newline at end of file -- cgit v1.2.3 From be4bfc78c493464cb0af40d7fae08ba86295a6f9 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 12 Jan 2016 20:49:34 +0100 Subject: Fixing #4256 and #4484 (changes in evar-evar resolution made that new evars were created making in turn that evars formerly recognized as pending were not anymore in the list of pending evars). This also fixes the reopening of #3848. See comments on #4484 for details. --- test-suite/bugs/closed/3848.v | 22 ++++++++++++++++++++++ test-suite/bugs/closed/4256.v | 43 +++++++++++++++++++++++++++++++++++++++++++ test-suite/bugs/closed/4484.v | 10 ++++++++++ test-suite/bugs/opened/3848.v | 22 ---------------------- 4 files changed, 75 insertions(+), 22 deletions(-) create mode 100644 test-suite/bugs/closed/3848.v create mode 100644 test-suite/bugs/closed/4256.v create mode 100644 test-suite/bugs/closed/4484.v delete mode 100644 test-suite/bugs/opened/3848.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3848.v b/test-suite/bugs/closed/3848.v new file mode 100644 index 0000000000..a03e8ffdab --- /dev/null +++ b/test-suite/bugs/closed/3848.v @@ -0,0 +1,22 @@ +Require Import TestSuite.admit. +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. +Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. +Arguments eisretr {A B} f {_} _. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). +Generalizable Variables A B f g e n. +Definition functor_forall `{P : A -> Type} `{Q : B -> Type} + (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) +: (forall a:A, P a) -> (forall b:B, Q b). + admit. +Defined. + +Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type} + `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} +: (forall b : B, Q b) -> forall a : A, P a. +Proof. + refine (functor_forall + (f^-1) + (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). +Fail Defined. (* Error: Attempt to save an incomplete proof *) diff --git a/test-suite/bugs/closed/4256.v b/test-suite/bugs/closed/4256.v new file mode 100644 index 0000000000..3cdc4ada02 --- /dev/null +++ b/test-suite/bugs/closed/4256.v @@ -0,0 +1,43 @@ +(* Testing 8.5 regression with type classes not solving evars + redefined while trying to solve them with the type class mechanism *) + +Global Set Universe Polymorphism. +Monomorphic Universe i. +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. +Notation "-1" := (trunc_S minus_two) (at level 0). + +Class IsPointed (A : Type) := point : A. +Arguments point A {_}. + +Record pType := + { pointed_type : Type ; + ispointed_type : IsPointed pointed_type }. +Coercion pointed_type : pType >-> Sortclass. +Existing Instance ispointed_type. + +Private Inductive Trunc (n : trunc_index) (A :Type) : Type := + tr : A -> Trunc n A. +Arguments tr {n A} a. + + + +Record ooGroup := + { classifying_space : pType@{i} }. + +Definition group_loops (X : pType) +: ooGroup. +Proof. + (** This works: *) + pose (x0 := point X). + pose (H := existT (fun x:X => Trunc -1 (x = point X)) x0 (tr idpath)). + clear H x0. + (** But this doesn't: *) + pose (existT (fun x:X => Trunc -1 (x = point X)) (point X) (tr idpath)). diff --git a/test-suite/bugs/closed/4484.v b/test-suite/bugs/closed/4484.v new file mode 100644 index 0000000000..f988539d62 --- /dev/null +++ b/test-suite/bugs/closed/4484.v @@ -0,0 +1,10 @@ +(* Testing 8.5 regression with type classes not solving evars + redefined while trying to solve them with the type class mechanism *) + +Class A := {}. +Axiom foo : forall {ac : A}, bool. +Lemma bar (ac : A) : True. +Check (match foo as k return foo = k -> True with + | true => _ + | false => _ + end eq_refl). diff --git a/test-suite/bugs/opened/3848.v b/test-suite/bugs/opened/3848.v deleted file mode 100644 index a03e8ffdab..0000000000 --- a/test-suite/bugs/opened/3848.v +++ /dev/null @@ -1,22 +0,0 @@ -Require Import TestSuite.admit. -Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. -Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). -Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. -Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }. -Arguments eisretr {A B} f {_} _. -Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). -Generalizable Variables A B f g e n. -Definition functor_forall `{P : A -> Type} `{Q : B -> Type} - (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b) -: (forall a:A, P a) -> (forall b:B, Q b). - admit. -Defined. - -Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type} - `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)} -: (forall b : B, Q b) -> forall a : A, P a. -Proof. - refine (functor_forall - (f^-1) - (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). -Fail Defined. (* Error: Attempt to save an incomplete proof *) -- cgit v1.2.3 From 9f8ae1aa2678944888d80ce0867bfb2bba0c8c71 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Tue, 12 Jan 2016 22:12:40 +0100 Subject: Fixing #4467 (missing shadowing of variables in cases pattern). This fixes a TODO in map_constr_expr_with_binders, a bug in is_constructor, as well as a bug and TODOS in ids_of_cases_indtype. --- test-suite/bugs/closed/4467.v | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 test-suite/bugs/closed/4467.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4467.v b/test-suite/bugs/closed/4467.v new file mode 100644 index 0000000000..6f8631d458 --- /dev/null +++ b/test-suite/bugs/closed/4467.v @@ -0,0 +1,15 @@ +(* Fixing missing test for variable shadowing *) + +Definition test (x y:bool*bool) := + match x with + | (e as e1, (true) as e2) + | ((true) as e1, e as e2) => + let '(e, b) := y in + e + | _ => true + end. + +Goal test (true,false) (true,true) = true. +(* used to evaluate to "false = true" in 8.4 *) +reflexivity. +Qed. -- cgit v1.2.3 From 2d568a895d5c8a246f497c94c79811d3aad4269f Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 13 Jan 2016 00:20:46 +0100 Subject: Fixing #4467 (continued). Function is_constructor was not properly fixed. Additionally, this fixes a problem with the 8.5 interpretation of in-pattern (see Cases.v). --- test-suite/success/Cases.v | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index e42663505d..49c465b6c6 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -1861,3 +1861,10 @@ Type (fun n => match n with Definition transport {A} (P : A->Type) {x y : A} (p : x=y) (u : P x) : P y := match p with eq_refl => u end. + +(* Check in-pattern clauses with constant constructors, which were + previously interpreted as variables (before 8.5) *) + +Check match eq_refl 0 in _=O return O=O with eq_refl => eq_refl end. + +Check match niln in listn O return O=O with niln => eq_refl end. -- cgit v1.2.3 From 245affffb174fb26fc9a847abe44e01b107980a8 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Wed, 13 Jan 2016 00:48:37 +0100 Subject: Fixing success of test for #3848 after move to directory "closed". --- test-suite/bugs/closed/3848.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3848.v b/test-suite/bugs/closed/3848.v index a03e8ffdab..c0ef02f1e8 100644 --- a/test-suite/bugs/closed/3848.v +++ b/test-suite/bugs/closed/3848.v @@ -19,4 +19,4 @@ Proof. refine (functor_forall (f^-1) (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). -Fail Defined. (* Error: Attempt to save an incomplete proof *) +Defined. (* was: Error: Attempt to save an incomplete proof *) -- cgit v1.2.3 From cbef33066dd526516c03474ffb35457047093808 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 19 Jan 2016 14:09:55 -0500 Subject: Fix bug #4420: check_types was losing universe constraints. --- test-suite/bugs/closed/4420.v | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 test-suite/bugs/closed/4420.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4420.v b/test-suite/bugs/closed/4420.v new file mode 100644 index 0000000000..0e16cb2399 --- /dev/null +++ b/test-suite/bugs/closed/4420.v @@ -0,0 +1,19 @@ +Module foo. + Context (Char : Type). + Axiom foo : Type -> Type. + Goal foo Char = foo Char. + change foo with (fun x => foo x). + cbv beta. + reflexivity. + Defined. +End foo. + +Inductive foo (A : Type) : Prop := I. (*Top.1*) +Lemma bar : foo Type. (*Top.3*) +Proof. + Set Printing Universes. +change foo with (fun x : Type => foo x). (*Top.4*) +cbv beta. +apply I. (* I Type@{Top.3} : (fun x : Type@{Top.4} => foo x) Type@{Top.3} *) +Defined. + -- cgit v1.2.3 From 86f5c0cbfa64c5d0949365369529c5b607878ef8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 20 Jan 2016 17:25:10 +0100 Subject: Update copyright headers. --- test-suite/bench/lists-100.v | 2 +- test-suite/bench/lists_100.v | 2 +- test-suite/failure/Tauto.v | 2 +- test-suite/failure/clash_cons.v | 2 +- test-suite/failure/fixpoint1.v | 2 +- test-suite/failure/guard.v | 2 +- test-suite/failure/illtype1.v | 2 +- test-suite/failure/positivity.v | 2 +- test-suite/failure/redef.v | 2 +- test-suite/failure/search.v | 2 +- test-suite/ideal-features/Apply.v | 2 +- test-suite/misc/berardi_test.v | 2 +- test-suite/success/Check.v | 2 +- test-suite/success/Field.v | 2 +- test-suite/success/Tauto.v | 2 +- test-suite/success/TestRefine.v | 2 +- test-suite/success/eauto.v | 2 +- test-suite/success/eqdecide.v | 2 +- test-suite/success/extraction.v | 2 +- test-suite/success/inds_type_sec.v | 2 +- test-suite/success/induct.v | 2 +- test-suite/success/mutual_ind.v | 2 +- test-suite/success/unfold.v | 2 +- test-suite/typeclasses/NewSetoid.v | 2 +- 24 files changed, 24 insertions(+), 24 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bench/lists-100.v b/test-suite/bench/lists-100.v index 352c7cea74..5c64716c72 100644 --- a/test-suite/bench/lists-100.v +++ b/test-suite/bench/lists-100.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* . - reflexivity. - exact I. Qed. + +(* Fixing a bug when destructing a type with let-ins in the constructor *) + +Inductive I := C : let x:=1 in x=1 -> I. +Goal I -> True. +intros [x H]. (* Was failing in 8.5 *) +Abort. -- cgit v1.2.3 From 4b075af747f65bcd73ff1c78417cf77edf6fbd76 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 21 Jan 2016 01:13:56 +0100 Subject: Fixing some problems with double induction. Basically, the hypotheses were treated in an incorrect order, with a hack for sometimes put them again in the right order, resulting in failures and redundant hypotheses. Status unclear, because this new version is incompatible except in simple cases like a double induction on two "nat". Fixing the bug incidentally simplify the code, relying on the deprecation since 8.4 to allow not to ensure a compatibility (beyond the simple situation of a double induction on simple datatypes). See file induct.v for effect of changes. --- test-suite/success/induct.v | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v index 7ae60d9892..9413b8dae9 100644 --- a/test-suite/success/induct.v +++ b/test-suite/success/induct.v @@ -151,3 +151,46 @@ intros x H1 H. induction H. change (0 = z -> True) in IHrepr''. Abort. + +(* Test double induction *) + +(* This was failing in 8.5 and before because of a bug in the order of + hypotheses *) + +Inductive I2 : Type := + C2 : forall x:nat, x=x -> I2. +Goal forall a b:I2, a = b. +double induction a b. +Abort. + +(* This was leaving useless hypotheses in 8.5 and before because of + the same bug. This is a change of compatibility. *) + +Inductive I3 : Prop := + C3 : forall x:nat, x=x -> I3. +Goal forall a b:I3, a = b. +double induction a b. +Fail clear H. (* H should have been erased *) +Abort. + +(* This one had quantification in reverse order in 8.5 and before *) +(* This is a change of compatibility. *) + +Goal forall m n, le m n -> le n m -> n=m. +intros m n. double induction 1 2. +3:destruct 1. (* Should be "S m0 <= m0" *) +Abort. + +(* Idem *) + +Goal forall m n p q, le m n -> le p q -> n+p=m+q. +intros *. double induction 1 2. +3:clear H2. (* H2 should have been erased *) +Abort. + +(* This is unchanged *) + +Goal forall m n:nat, n=m. +double induction m n. +Abort. + -- cgit v1.2.3 From 9c2662eecc398f38be3b6280a8f760cc439bc31c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 21 Jan 2016 01:43:10 +0100 Subject: Stronger invariants on the use of the introduction pattern (pat1,...,patn). The length of the pattern should now be exactly the number of assumptions and definitions introduced by the destruction or induction, including the induction hypotheses in case of an induction. Like for pattern-matching, the local definitions in the argument of the constructor can be skipped in which case a name is automatically created for these. --- test-suite/success/intros.v | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index af5f994010..ee69df9774 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -105,3 +105,26 @@ Inductive I := C : let x:=1 in x=1 -> I. Goal I -> True. intros [x H]. (* Was failing in 8.5 *) Abort. + +(* Ensuring that the (pat1,...,patn) intropatterns has the expected size, up + to skipping let-ins *) + +Goal I -> 1=1. +intros (H). (* This skips x *) +exact H. +Qed. + +Goal I -> 1=1. +Fail intros (x,H,H'). +Fail intros [|]. +intros (x,H). +exact H. +Qed. + +Goal Acc le 0 -> True. +Fail induction 1 as (n,H). (* Induction hypothesis is missing *) +induction 1 as (n,H,IH). +exact Logic.I. +Qed. + + -- cgit v1.2.3 From 6a046f8d3e33701d70e2a391741e65564cc0554d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 23 Jan 2016 15:55:43 -0500 Subject: Fix bug #4519: oops, global shadowed local universe level bindings. --- test-suite/bugs/closed/4519.v | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 test-suite/bugs/closed/4519.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4519.v b/test-suite/bugs/closed/4519.v new file mode 100644 index 0000000000..ccbc47d20f --- /dev/null +++ b/test-suite/bugs/closed/4519.v @@ -0,0 +1,21 @@ +Set Universe Polymorphism. +Section foo. + Universe i. + Context (foo : Type@{i}) (bar : Type@{i}). + Definition qux@{i} (baz : Type@{i}) := foo -> bar. +End foo. +Set Printing Universes. +Print qux. (* qux@{Top.42 Top.43} = +fun foo bar _ : Type@{Top.42} => foo -> bar + : Type@{Top.42} -> Type@{Top.42} -> Type@{Top.42} -> Type@{Top.42} +(* Top.42 Top.43 |= *) +(* This is wrong; the first two types are equal, but the last one is not *) + +qux is universe polymorphic +Argument scopes are [type_scope type_scope type_scope] + *) +Check qux nat nat nat : Set. +Check qux nat nat Set : Set. (* Error: +The term "qux@{Top.50 Top.51} ?T ?T0 Set" has type "Type@{Top.50}" while it is +expected to have type "Set" +(universe inconsistency: Cannot enforce Top.50 = Set because Set < Top.50). *) \ No newline at end of file -- cgit v1.2.3 From b582db2ecbb3f7f1315fedc50b0009f62f5c59ad Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 23 Jan 2016 17:28:34 -0500 Subject: Fix bug #4503: mixing universe polymorphic and monomorphic variables and definitions in sections is unsupported. --- test-suite/bugs/closed/4503.v | 37 +++++++++++++++++++++++++++++++++++ test-suite/bugs/closed/HoTT_coq_002.v | 2 +- test-suite/bugs/closed/HoTT_coq_020.v | 4 ++-- 3 files changed, 40 insertions(+), 3 deletions(-) create mode 100644 test-suite/bugs/closed/4503.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4503.v b/test-suite/bugs/closed/4503.v new file mode 100644 index 0000000000..f54d6433d8 --- /dev/null +++ b/test-suite/bugs/closed/4503.v @@ -0,0 +1,37 @@ +Require Coq.Classes.RelationClasses. + +Class PreOrder (A : Type) (r : A -> A -> Type) : Type := +{ refl : forall x, r x x }. + +(* FAILURE 1 *) + +Section foo. + Polymorphic Universes A. + Polymorphic Context {A : Type@{A}} {rA : A -> A -> Prop} {PO : PreOrder A rA}. + + Fail Definition foo := PO. +End foo. + + +Module ILogic. + +Set Universe Polymorphism. + +(* Logical connectives *) +Class ILogic@{L} (A : Type@{L}) : Type := mkILogic +{ + lentails: A -> A -> Prop; + lentailsPre:> RelationClasses.PreOrder lentails +}. + + +End ILogic. + +Set Printing Universes. + +(* There is stil 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}. + +End Embed_ILogic_Pre. \ No newline at end of file diff --git a/test-suite/bugs/closed/HoTT_coq_002.v b/test-suite/bugs/closed/HoTT_coq_002.v index ba69f6b158..dba4d5998f 100644 --- a/test-suite/bugs/closed/HoTT_coq_002.v +++ b/test-suite/bugs/closed/HoTT_coq_002.v @@ -9,7 +9,7 @@ Section SpecializedFunctor. (* Variable objC : Type. *) Context `(C : SpecializedCategory objC). - Polymorphic Record SpecializedFunctor := { + Record SpecializedFunctor := { ObjectOf' : objC -> Type; ObjectC : Object C }. diff --git a/test-suite/bugs/closed/HoTT_coq_020.v b/test-suite/bugs/closed/HoTT_coq_020.v index 4938b80f9b..008fb72c4e 100644 --- a/test-suite/bugs/closed/HoTT_coq_020.v +++ b/test-suite/bugs/closed/HoTT_coq_020.v @@ -59,8 +59,8 @@ Polymorphic Definition FunctorFrom0 objC (C : Category objC) : Functor Cat0 C := Build_Functor Cat0 C (fun x => match x with end). Section Law0. - Variable objC : Type. - Variable C : Category objC. + Polymorphic Variable objC : Type. + Polymorphic Variable C : Category objC. Set Printing All. Set Printing Universes. -- cgit v1.2.3 From 4b1103dc38754917e12bf04feca446e02cf55f07 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 24 Jan 2016 12:17:21 +0100 Subject: Fixing bug #4511: evar tactic can create non-typed evars. --- test-suite/bugs/closed/4511.v | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 test-suite/bugs/closed/4511.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4511.v b/test-suite/bugs/closed/4511.v new file mode 100644 index 0000000000..0cdb3aee4f --- /dev/null +++ b/test-suite/bugs/closed/4511.v @@ -0,0 +1,3 @@ +Goal True. +Fail evar I. + -- cgit v1.2.3 From cb30837323aa462df24ad6668790f67b9bf20b5d Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 24 Jan 2016 12:35:49 +0100 Subject: Fixing bug #4495: Failed assertion in metasyntax.ml. We simply handle the "break" in error messages. Not sure it is the proper bugfix though, we may want to be able to add breaks in such recursive notations. --- test-suite/bugs/closed/4495.v | 1 + 1 file changed, 1 insertion(+) create mode 100644 test-suite/bugs/closed/4495.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4495.v b/test-suite/bugs/closed/4495.v new file mode 100644 index 0000000000..8b032db5f5 --- /dev/null +++ b/test-suite/bugs/closed/4495.v @@ -0,0 +1 @@ +Fail Notation "'forall' x .. y ',' P " := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder). -- cgit v1.2.3 From e7852396a452f446135183ec3e1743b731d781c0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 24 Jan 2016 14:18:40 +0100 Subject: Adding a test for bug #4378. --- test-suite/bugs/closed/4378.v | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 test-suite/bugs/closed/4378.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4378.v b/test-suite/bugs/closed/4378.v new file mode 100644 index 0000000000..9d59165562 --- /dev/null +++ b/test-suite/bugs/closed/4378.v @@ -0,0 +1,9 @@ +Tactic Notation "epose" open_constr(a) := + let a' := fresh in + pose a as a'. +Tactic Notation "epose2" open_constr(a) tactic3(tac) := + let a' := fresh in + pose a as a'. +Goal True. + epose _. Undo. + epose2 _ idtac. -- cgit v1.2.3 From f46a5686853353f8de733ae7fbd21a3a61977bc7 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 3 Feb 2016 15:32:58 +0100 Subject: Do not give a name to anonymous evars anymore. See bug #4547. The current solution may not be totally ideal though. We generate names for anonymous evars on the fly at printing time, based on the Evar_kind data they are wearing. This means in particular that the printed name of an anonymous evar may change in the future because some unrelate evar has been solved or introduced. --- test-suite/bugs/closed/3068.v | 2 +- test-suite/output/Existentials.out | 3 +-- test-suite/output/Notations.out | 14 +++++++------- test-suite/output/inference.out | 8 ++++---- test-suite/success/apply.v | 2 +- test-suite/success/destruct.v | 8 ++++---- 6 files changed, 18 insertions(+), 19 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3068.v b/test-suite/bugs/closed/3068.v index ced6d95949..79671ce930 100644 --- a/test-suite/bugs/closed/3068.v +++ b/test-suite/bugs/closed/3068.v @@ -56,7 +56,7 @@ Section Finite_nat_set. subst fs1. apply iff_refl. intros H. - eapply counted_list_equal_nth_char. + eapply (counted_list_equal_nth_char _ _ _ _ ?[def]). intros i. destruct (counted_def_nth fs1 i _ ) eqn:H0. (* This was not part of the initial bug report; this is to check that diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out index 52e1e0ed01..9680d2bbff 100644 --- a/test-suite/output/Existentials.out +++ b/test-suite/output/Existentials.out @@ -1,5 +1,4 @@ -Existential 1 = -?Goal1 : [p : nat q := S p : nat n : nat m : nat |- ?y = m] +Existential 1 = ?Goal : [p : nat q := S p : nat n : nat m : nat |- ?y = m] Existential 2 = ?y : [p : nat q := S p : nat n : nat m : nat |- nat] (p, q cannot be used) Existential 3 = ?Goal0 : [q : nat n : nat m : nat |- n = ?y] diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index b1558dab1c..26eaca8272 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -111,14 +111,14 @@ fun x : option Z => match x with | NONE2 => 0 end : option Z -> Z -fun x : list ?T1 => match x with - | NIL => NONE2 - | (_ :') t => SOME2 t - end - : list ?T1 -> option (list ?T1) +fun x : list ?T => match x with + | NIL => NONE2 + | (_ :') t => SOME2 t + end + : list ?T -> option (list ?T) where -?T1 : [x : list ?T1 x1 : list ?T1 x0 := x1 : list ?T1 |- Type] (x, x1, - x0 cannot be used) +?T : [x : list ?T x1 : list ?T x0 := x1 : list ?T |- Type] (x, x1, + x0 cannot be used) s : s 10 diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index f2d1447785..4512e2c5ce 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -9,10 +9,10 @@ fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H fun n : nat => let x := A n in ?y ?y0 : T n : forall n : nat, T n where -?y : [n : nat x := A n : T n |- ?T0 -> T n] -?y0 : [n : nat x := A n : T n |- ?T0] +?y : [n : nat x := A n : T n |- ?T -> T n] +?y0 : [n : nat x := A n : T n |- ?T] fun n : nat => ?y ?y0 : T n : forall n : nat, T n where -?y : [n : nat |- ?T0 -> T n] -?y0 : [n : nat |- ?T0] +?y : [n : nat |- ?T -> T n] +?y0 : [n : nat |- ?T] diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index 55b666b723..02e043bc36 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -543,7 +543,7 @@ Qed. Lemma bar (X: nat -> nat -> Prop) (foo:forall x, X x x) (a: unit) (H: tt = a): exists x, exists y, X x y. Proof. -intros; eexists; eexists; case H. +intros; eexists; eexists ?[y]; case H. apply (foo ?y). Grab Existential Variables. exact 0. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 9f091e3996..90a60daa66 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -96,21 +96,21 @@ Abort. (* Check that subterm selection does not solve existing evars *) Goal exists x, S x = S 0. -eexists. +eexists ?[x]. Show x. (* Incidentally test Show on a named goal *) destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) change (0 = S 0). Abort. Goal exists x, S 0 = S x. -eexists. +eexists ?[x]. destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) change (0 = S ?x). [x]: exact 0. (* Incidentally test applying a tactic to a goal on the shelve *) Abort. Goal exists n p:nat, (S n,S n) = (S p,S p) /\ p = n. -do 2 eexists. +eexists ?[n]; eexists ?[p]. destruct (_, S _). (* Was unifying at some time in trunk, now takes the first occurrence *) change ((n, n0) = (S ?p, S ?p) /\ ?p = ?n). Abort. @@ -426,7 +426,7 @@ destruct b eqn:H. (* Check natural instantiation behavior when the goal has already an evar *) Goal exists x, S x = x. -eexists. +eexists ?[x]. destruct (S _). change (0 = ?x). Abort. -- cgit v1.2.3 From 65b901534649c5f29e245a4960fa66f6e9d9c257 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 17 Feb 2016 18:11:02 +0100 Subject: Fix bug #4574: Anomaly: Uncaught exception Invalid_argument("splay_arity"). The setoid_rewrite tactic was not checking that the relation it was looking for was indeed a relation, i.e. that its type was an arity. --- test-suite/bugs/closed/4574.v | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 test-suite/bugs/closed/4574.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4574.v b/test-suite/bugs/closed/4574.v new file mode 100644 index 0000000000..39ba190369 --- /dev/null +++ b/test-suite/bugs/closed/4574.v @@ -0,0 +1,8 @@ +Require Import Setoid. + +Definition block A (a : A) := a. + +Goal forall A (a : A), block Type nat. +Proof. +Fail reflexivity. + -- cgit v1.2.3 From 9aa2d99fb1ad6b348142fce244f277b9dd25017f Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Fri, 19 Feb 2016 11:51:04 +0100 Subject: STM: Print/Extraction have to be skipped if -quick Print and Extraction commands may pierce opacity: if the task producing the proof term is not finished, we wait for its completion. In -quick mode no worker is going to process a task, since tasks are simply stored to disk (and resumed later in -vio2vo mode). This commit avoids coqc waits forever for a task in order to Print/Extract the corresponding term. Bug reported privately by Alec Faithfull. --- test-suite/vio/print.v | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 test-suite/vio/print.v (limited to 'test-suite') diff --git a/test-suite/vio/print.v b/test-suite/vio/print.v new file mode 100644 index 0000000000..9c36a463c9 --- /dev/null +++ b/test-suite/vio/print.v @@ -0,0 +1,10 @@ +Lemma a : True. +Proof. +idtac. +exact I. +Qed. + +Print a. + +Lemma b : False. +Admitted. -- cgit v1.2.3 From d3012c8ac308b18272ddaa90c4eae7e517b63c7c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 19 Feb 2016 13:59:33 +0100 Subject: Fixing bug #4582: cannot override notation [ x ]. --- test-suite/bugs/closed/4582.v | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 test-suite/bugs/closed/4582.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4582.v b/test-suite/bugs/closed/4582.v new file mode 100644 index 0000000000..0842fb8fa7 --- /dev/null +++ b/test-suite/bugs/closed/4582.v @@ -0,0 +1,10 @@ +Require List. +Import List.ListNotations. + +Variable Foo : nat -> nat. + +Delimit Scope Foo_scope with F. + +Notation " [ x ] " := (Foo x) : Foo_scope. + +Check ([1] : nat)%F. -- cgit v1.2.3 From 924d2833644735a9fa8289ffaa9bac9fbc43982c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 19 Feb 2016 14:27:31 +0100 Subject: Fixing bug #4580: [Set Refine Instance Mode] also used for Program Instance. --- test-suite/bugs/closed/4580.v | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 test-suite/bugs/closed/4580.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4580.v b/test-suite/bugs/closed/4580.v new file mode 100644 index 0000000000..4ffd5f0f4b --- /dev/null +++ b/test-suite/bugs/closed/4580.v @@ -0,0 +1,6 @@ +Require Import Program. + +Class Foo (A : Type) := foo : A. + +Unset Refine Instance Mode. +Program Instance f1 : Foo nat := S _. -- cgit v1.2.3 From 33fe6e61ff2f1f8184373ed8fccc403591c4605a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 21 Feb 2016 17:13:26 +0100 Subject: Moving the Tauto tactic to proper Ltac. This gets rid of brittle code written in ML files through Ltac quotations, and reduces the dependance of Coq to such a feature. This also fixes the particular instance of bug #2800, although the underlying issue is still there. --- test-suite/bugs/closed/2800.v | 6 ++++++ test-suite/bugs/opened/2800.v | 6 ------ 2 files changed, 6 insertions(+), 6 deletions(-) create mode 100644 test-suite/bugs/closed/2800.v delete mode 100644 test-suite/bugs/opened/2800.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/2800.v b/test-suite/bugs/closed/2800.v new file mode 100644 index 0000000000..2ee438934e --- /dev/null +++ b/test-suite/bugs/closed/2800.v @@ -0,0 +1,6 @@ +Goal False. + +intuition + match goal with + | |- _ => idtac " foo" + end. diff --git a/test-suite/bugs/opened/2800.v b/test-suite/bugs/opened/2800.v deleted file mode 100644 index c559ab0c17..0000000000 --- a/test-suite/bugs/opened/2800.v +++ /dev/null @@ -1,6 +0,0 @@ -Goal False. - -Fail intuition - match goal with - | |- _ => idtac " foo" - end. -- cgit v1.2.3 From e7b292de756b335069fce9d9a999904ea2af6630 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 23 Feb 2016 18:21:02 +0100 Subject: Document differences of Hint Resolve and Hint Extern --- test-suite/success/auto.v | 89 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v index aaa7b3a514..5477c83316 100644 --- a/test-suite/success/auto.v +++ b/test-suite/success/auto.v @@ -45,3 +45,92 @@ Proof. eexists. Fail progress debug eauto with test2. progress eauto with test. Qed. + +(** Patterns of Extern have a "matching" semantics. + It is not so for apply/exact hints *) + +Class B (A : Type). +Class I. +Instance i : I. + +Definition flip {A B C : Type} (f : A -> B -> C) := fun y x => f x y. +Class D (f : nat -> nat -> nat). +Definition ftest (x y : nat) := x + y. +Definition flipD (f : nat -> nat -> nat) : D f -> D (flip f). + Admitted. +Module Instnopat. + Local Instance: B nat. + (* pattern_of_constr -> B nat *) + (* exact hint *) + Check (_ : B nat). + (* map_eauto -> B_instance0 *) + (* NO Constr_matching.matches !!! *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + eauto with typeclass_instances. + Qed. + + Local Instance: D ftest. + Local Hint Resolve flipD | 0 : typeclass_instances. + (* pattern: D (flip _) *) + Fail Timeout 1 Check (_ : D _). (* loops applying flipD *) + +End Instnopat. + +Module InstnopatApply. + Local Instance: I -> B nat. + (* pattern_of_constr -> B nat *) + (* apply hint *) + Check (_ : B nat). + (* map_eauto -> B_instance0 *) + (* NO Constr_matching.matches !!! *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + eauto with typeclass_instances. + Qed. +End InstnopatApply. + +Module InstPat. + Hint Extern 3 (B nat) => split : typeclass_instances. + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> true *) + Check (_ : B nat). + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> false: + Because an inductive in the pattern does not match an evar in the goal *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + (* map_existential -> Extern hint *) + (* Constr_matching.matches -> false *) + Fail progress eauto with typeclass_instances. + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> false *) + Fail typeclasses eauto. + Abort. + + Hint Extern 0 (D (flip _)) => apply flipD : typeclass_instances. + Module withftest. + Local Instance: D ftest. + + Check (_ : D _). + (* D_instance_0 : D ftest *) + Check (_ : D (flip _)). + (* ... : D (flip ftest) *) + End withftest. + Module withoutftest. + Hint Extern 0 (D ftest) => split : typeclass_instances. + Check (_ : D _). + (* ? : D ?, _not_ looping *) + Check (_ : D (flip _)). + (* ? : D (flip ?), _not_ looping *) + + Check (_ : D (flip ftest)). + (* flipD ftest {| |} : D (flip ftest) *) + End withoutftest. +End InstPat. -- cgit v1.2.3 From db2c6f0054d3e05f82da7494ce790c04b1976401 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 28 Feb 2016 13:19:47 +0100 Subject: Fixing bug #4596: [rewrite] broke in the past few weeks. Checking that a term was indeed a relation was made too early, as the decomposition function recognized relations of the form "f (g .. (h x y)) with f, g unary and only h binary. We postpone this check to the very end. --- test-suite/bugs/closed/4596.v | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 test-suite/bugs/closed/4596.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4596.v b/test-suite/bugs/closed/4596.v new file mode 100644 index 0000000000..592fdb6580 --- /dev/null +++ b/test-suite/bugs/closed/4596.v @@ -0,0 +1,14 @@ +Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms. + +Definition T (x : bool) := x = true. + +Goal forall (S : Type) (b b0 : S -> nat -> bool) (str : S) (p : nat) + (s : forall n : nat, bool) + (s0 s1 : nat -> S -> S), + (forall (str0 : S) (n m : nat), + (if s m then T (b0 (s1 n str0) 0) else T (b (s1 n str0) 0)) -> T (b (s0 n str0) m) -> + T (b str0 m)) -> + T (b str p). +Proof. +intros ???????? H0. +rewrite H0. -- cgit v1.2.3 From d0bc16d1a0626f4137797bbf0c91e972a0ff43ac Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 29 Feb 2016 11:05:26 +0100 Subject: Moving the "clear" tactic to TACTIC EXTEND. --- test-suite/bugs/closed/3612.v | 3 +++ 1 file changed, 3 insertions(+) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v index 9125ab16dd..25060debe2 100644 --- a/test-suite/bugs/closed/3612.v +++ b/test-suite/bugs/closed/3612.v @@ -35,6 +35,9 @@ Axiom path_path_sigma : forall {A : Type} (P : A -> Type) (u v : sigT P) (r : p..1 = q..1) (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2), p = q. + +Declare ML Module "coretactics". + Goal forall (A : Type) (B : forall _ : A, Type) (x : @sigT A (fun x : A => B x)) (xx : @paths (@sigT A (fun x0 : A => B x0)) x x), @paths (@paths (@sigT A (fun x0 : A => B x0)) x x) xx -- cgit v1.2.3 From 7461aaedef508570fba6334e18fd10d5b32bda0e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 3 Mar 2016 21:35:42 +0100 Subject: Adding a test for the behaviour of open_constr described in #3777. --- test-suite/typeclasses/open_constr.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 test-suite/typeclasses/open_constr.v (limited to 'test-suite') diff --git a/test-suite/typeclasses/open_constr.v b/test-suite/typeclasses/open_constr.v new file mode 100644 index 0000000000..5f1785c706 --- /dev/null +++ b/test-suite/typeclasses/open_constr.v @@ -0,0 +1,12 @@ +Tactic Notation "opose" open_constr(foo) := pose foo. +Class Foo := Build_Foo : Set. +Axiom f : forall `{Foo}, Set. +Set Printing Implicit. +Goal forall `{Foo}, True. +Proof. + intro H. + pose f. + opose f. + Fail let x := (eval hnf in P) in has_evar x. + let x := (eval hnf in P0) in has_evar x. + -- cgit v1.2.3 From d5656a6c28f79d59590d4fde60c5158a649d1b65 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Mar 2016 11:16:03 +0100 Subject: Making parentheses mandatory in tactic scopes. --- test-suite/bugs/closed/3699.v | 4 ++-- test-suite/bugs/closed/3881.v | 2 +- test-suite/complexity/ring2.v | 2 +- test-suite/success/MatchFail.v | 8 ++++---- test-suite/success/ltac.v | 14 +++++++------- 5 files changed, 15 insertions(+), 15 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v index aad0bb44d5..8dadc2419c 100644 --- a/test-suite/bugs/closed/3699.v +++ b/test-suite/bugs/closed/3699.v @@ -65,7 +65,7 @@ Module NonPrim. set (fibermap := fun a0p : hfiber f (f a) => let (a0, p) := a0p in transport P p (d a0)). Set Printing Implicit. - let G := match goal with |- ?G => constr:G end in + let G := match goal with |- ?G => constr:(G) end in first [ match goal with | [ |- (@isconnected_elim n (@hfiber A B f (f a)) (@isconnected_hfiber_conn_map n A B f H (f a)) @@ -142,7 +142,7 @@ Module Prim. set (fibermap := fun a0p : hfiber f (f a) => let (a0, p) := a0p in transport P p (d a0)). Set Printing Implicit. - let G := match goal with |- ?G => constr:G end in + let G := match goal with |- ?G => constr:(G) end in first [ match goal with | [ |- (@isconnected_elim n (@hfiber A B f (f a)) (@isconnected_hfiber_conn_map n A B f H (f a)) diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v index 070d1e9c71..a327bbf2a9 100644 --- a/test-suite/bugs/closed/3881.v +++ b/test-suite/bugs/closed/3881.v @@ -23,7 +23,7 @@ Proof. pose (fun H => @isequiv_homotopic _ _ ((g o f) o f^-1) _ H (fun b => ap g (eisretr f b))) as k. revert k. - let x := match goal with |- let k := ?x in _ => constr:x end in + let x := match goal with |- let k := ?x in _ => constr:(x) end in intro k; clear k; pose (x _). pose (@isequiv_homotopic _ _ ((g o f) o f^-1) g _ diff --git a/test-suite/complexity/ring2.v b/test-suite/complexity/ring2.v index 52dae265bd..04fa59075b 100644 --- a/test-suite/complexity/ring2.v +++ b/test-suite/complexity/ring2.v @@ -39,7 +39,7 @@ Admitted. Ltac Zcst t := match isZcst t with true => t - | _ => constr:NotConstant + | _ => constr:(NotConstant) end. Add Ring Zr : Zth diff --git a/test-suite/success/MatchFail.v b/test-suite/success/MatchFail.v index 7069bba430..8462d36272 100644 --- a/test-suite/success/MatchFail.v +++ b/test-suite/success/MatchFail.v @@ -9,14 +9,14 @@ Require Export ZArithRing. Ltac compute_POS := match goal with | |- context [(Zpos (xI ?X1))] => - let v := constr:X1 in - match constr:v with + let v := constr:(X1) in + match constr:(v) with | 1%positive => fail 1 | _ => rewrite (BinInt.Pos2Z.inj_xI v) end | |- context [(Zpos (xO ?X1))] => - let v := constr:X1 in - match constr:v with + let v := constr:(X1) in + match constr:(v) with | 1%positive => fail 1 | _ => rewrite (BinInt.Pos2Z.inj_xO v) end diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 6c4d4ae98f..ce90990594 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -15,7 +15,7 @@ Ltac F x := idtac; G x with G y := idtac; F y. (* Check that Match Context keeps a closure *) -Ltac U := let a := constr:I in +Ltac U := let a := constr:(I) in match goal with | |- _ => apply a end. @@ -75,7 +75,7 @@ Qed. (* Check context binding *) Ltac sym t := - match constr:t with + match constr:(t) with | context C[(?X1 = ?X2)] => context C [X1 = X2] end. @@ -143,7 +143,7 @@ Qed. Ltac check_binding y := cut ((fun y => y) = S). Goal True. -check_binding ipattern:H. +check_binding ipattern:(H). Abort. (* Check that variables explicitly parsed as ltac variables are not @@ -151,7 +151,7 @@ Abort. Ltac afi tac := intros; tac. Goal 1 = 2. -afi ltac:auto. +afi ltac:(auto). Abort. (* Tactic Notation avec listes *) @@ -174,7 +174,7 @@ Abort. empty args *) Goal True. -match constr:@None with @None => exact I end. +match constr:(@None) with @None => exact I end. Abort. (* Check second-order pattern unification *) @@ -218,7 +218,7 @@ Ltac Z1 t := set (x:=t). Ltac Z2 t := t. Goal True -> True. Z1 O. -Z2 ltac:O. +Z2 ltac:(O). exact I. Qed. @@ -302,7 +302,7 @@ Abort. (* Check instantiation of binders using ltac names *) Goal True. -let x := ipattern:y in assert (forall x y, x = y + 0). +let x := ipattern:(y) in assert (forall x y, x = y + 0). intro. destruct y. (* Check that the name is y here *) Abort. -- cgit v1.2.3 From eb0feed6d22c11c44e7091c64ce5b1c9d5af987a Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 5 Mar 2016 18:23:05 +0100 Subject: Using build_selector from Equality as a replacement of the selector in cctac which does not support indices properly. Incidentally, this should fix a failure in RelationAlgebra, where making prod_applist more robust (e8c47b652) revealed the discriminate bug in congruence. --- test-suite/success/cc.v | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'test-suite') diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v index a70d919635..dc0527d826 100644 --- a/test-suite/success/cc.v +++ b/test-suite/success/cc.v @@ -129,5 +129,10 @@ Qed. End bug_2447. +(* congruence was supposed to do discriminate but it was bugged for + types with indices *) - +Inductive I : nat -> Type := C : I 0 | D : I 0. +Goal ~C=D. +congruence. +Qed. -- cgit v1.2.3 From a5ae3b2856e6cc6683652a0abb5a84b9787527c0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 9 Mar 2016 15:15:38 +0100 Subject: Fix strategy of Keyed Unification Try first to find a keyed subterm without conversion/betaiota on open terms (that is the usual strategy of rewrite), if this fails, try with full conversion, incuding betaiota. This makes the test-suite pass again, retaining efficiency in the most common cases. --- test-suite/bugs/closed/4544.v | 1007 +++++++++++++++++++++++++++++++++++++ test-suite/success/keyedrewrite.v | 3 +- 2 files changed, 1009 insertions(+), 1 deletion(-) create mode 100644 test-suite/bugs/closed/4544.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4544.v b/test-suite/bugs/closed/4544.v new file mode 100644 index 0000000000..d14cc86fc7 --- /dev/null +++ b/test-suite/bugs/closed/4544.v @@ -0,0 +1,1007 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." "Top" "-top" "bug_oog_looping_rewrite_01") -*- *) +(* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *) +(* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 + coqtop version 8.5 (January 2016) *) +Inductive False := . +Axiom proof_admitted : False. +Tactic Notation "admit" := case proof_admitted. +Require Coq.Init.Datatypes. + +Import Coq.Init.Notations. + +Global Set Universe Polymorphism. + +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Global Set Primitive Projections. + +Inductive sum (A B : Type) : Type := + | inl : A -> sum A B + | inr : B -> sum A B. +Notation nat := Coq.Init.Datatypes.nat. +Notation S := Coq.Init.Datatypes.S. +Notation "x + y" := (sum x y) : type_scope. + +Record prod (A B : Type) := pair { fst : A ; snd : B }. + +Notation "x * y" := (prod x y) : type_scope. +Module Export Specif. + +Set Implicit Arguments. + +Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }. +Arguments proj1_sig {A P} _ / . + +Notation sigT := sig (only parsing). +Notation existT := exist (only parsing). + +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + +Notation projT1 := proj1_sig (only parsing). +Notation projT2 := proj2_sig (only parsing). + +End Specif. +Module Export HoTT_DOT_Basics_DOT_Overture. +Module Export HoTT. +Module Export Basics. +Module Export Overture. + +Global Set Keyed Unification. + +Global Unset Strict Universe Declaration. + +Notation Type0 := Set. + +Definition Type1@{i} := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. + +Definition Type2@{i j} := Eval hnf in let gt := (Type1@{j} : Type@{i}) in Type@{i}. + +Definition Type2le@{i j} := Eval hnf in let gt := (Set : Type@{i}) in + let ge := ((fun x => x) : Type1@{j} -> Type@{i}) in Type@{i}. + +Notation idmap := (fun x => x). +Delimit Scope function_scope with function. +Delimit Scope path_scope with path. +Delimit Scope fibration_scope with fibration. +Delimit Scope trunc_scope with trunc. + +Open Scope trunc_scope. +Open Scope path_scope. +Open Scope fibration_scope. +Open Scope nat_scope. +Open Scope function_scope. + +Notation "( x ; y )" := (existT _ x y) : fibration_scope. + +Notation pr1 := projT1. +Notation pr2 := projT2. + +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. +Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. + +Notation compose := (fun g f x => g (f x)). + +Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : function_scope. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +Notation "1" := idpath : path_scope. + +Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope. + +Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) + := forall x:A, f x = g x. + +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Arguments eisretr {A B}%type_scope f%function_scope {_} _. + +Record Equiv A B := BuildEquiv { + equiv_fun : A -> B ; + equiv_isequiv : IsEquiv equiv_fun +}. + +Coercion equiv_fun : Equiv >-> Funclass. + +Global Existing Instance equiv_isequiv. + +Notation "A <~> B" := (Equiv A B) (at level 85) : type_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : function_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. + +Arguments center A {_}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope. +Notation "-2" := minus_two (at level 0) : trunc_scope. +Notation "-1" := (-2.+1) (at level 0) : trunc_scope. +Notation "0" := (-1.+1) : trunc_scope. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Global Instance istrunc_paths (A : Type) n `{H : IsTrunc n.+1 A} (x y : A) +: IsTrunc n (x = y) + := H x y. + +Notation Contr := (IsTrunc -2). +Notation IsHProp := (IsTrunc -1). + +Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. + +Monomorphic Axiom dummy_funext_type : Type0. +Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }. + +Inductive Unit : Type1 := + tt : Unit. + +Class IsPointed (A : Type) := point : A. + +Arguments point A {_}. + +Record pType := + { pointed_type : Type ; + ispointed_type : IsPointed pointed_type }. + +Coercion pointed_type : pType >-> Sortclass. + +Global Existing Instance ispointed_type. + +Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. + +Ltac revert_opaque x := + revert x; + match goal with + | [ |- forall _, _ ] => idtac + | _ => fail 1 "Reverted constant is not an opaque variable" + end. + +End Overture. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_Overture. +Module Export HoTT_DOT_Basics_DOT_PathGroupoids. +Module Export HoTT. +Module Export Basics. +Module Export PathGroupoids. + +Local Open Scope path_scope. + +Definition concat_p1 {A : Type} {x y : A} (p : x = y) : + p @ 1 = p + := + match p with idpath => 1 end. + +Definition concat_1p {A : Type} {x y : A} (p : x = y) : + 1 @ p = p + := + match p with idpath => 1 end. + +Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + p @ (q @ r) = (p @ q) @ r := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + (p @ q) @ r = p @ (q @ r) := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition concat_pV {A : Type} {x y : A} (p : x = y) : + p @ p^ = 1 + := + match p with idpath => 1 end. + +Definition moveR_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : + p = r @ q -> r^ @ p = q. +admit. +Defined. + +Definition moveL_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : + r @ q = p -> q = r^ @ p. +admit. +Defined. + +Definition moveR_M1 {A : Type} {x y : A} (p q : x = y) : + 1 = p^ @ q -> p = q. +admit. +Defined. + +Definition ap_pp {A B : Type} (f : A -> B) {x y z : A} (p : x = y) (q : y = z) : + ap f (p @ q) = (ap f p) @ (ap f q) + := + match q with + idpath => + match p with idpath => 1 end + end. + +Definition ap_V {A B : Type} (f : A -> B) {x y : A} (p : x = y) : + ap f (p^) = (ap f p)^ + := + match p with idpath => 1 end. + +Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : + ap (g o f) p = ap g (ap f p) + := + match p with idpath => 1 end. + +Definition concat_pA1 {A : Type} {f : A -> A} (p : forall x, x = f x) {x y : A} (q : x = y) : + (p x) @ (ap f q) = q @ (p y) + := + match q as i in (_ = y) return (p x @ ap f i = i @ p y) with + | idpath => concat_p1 _ @ (concat_1p _)^ + end. + +End PathGroupoids. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_PathGroupoids. +Module Export HoTT_DOT_Basics_DOT_Equivalences. +Module Export HoTT. +Module Export Basics. +Module Export Equivalences. + +Definition isequiv_commsq {A B C D} + (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D) + (p : k o f == g o h) + `{IsEquiv _ _ f} `{IsEquiv _ _ h} `{IsEquiv _ _ k} +: IsEquiv g. +admit. +Defined. + +Section Adjointify. + + Context {A B : Type} (f : A -> B) (g : B -> A). + Context (isretr : Sect g f) (issect : Sect f g). + + Let issect' := fun x => + ap g (ap f (issect x)^) @ ap g (isretr (f x)) @ issect x. + + Let is_adjoint' (a : A) : isretr (f a) = ap f (issect' a). + Proof. + unfold issect'. + apply moveR_M1. + repeat rewrite ap_pp, concat_p_pp; rewrite <- ap_compose. + rewrite (concat_pA1 (fun b => (isretr b)^) (ap f (issect a)^)). + repeat rewrite concat_pp_p; rewrite ap_V; apply moveL_Vp; rewrite concat_p1. + rewrite concat_p_pp, <- ap_compose. + rewrite (concat_pA1 (fun b => (isretr b)^) (isretr (f a))). + rewrite concat_pV, concat_1p; reflexivity. + Qed. + + Definition isequiv_adjointify : IsEquiv f + := BuildIsEquiv A B f g isretr issect' is_adjoint'. + +End Adjointify. + +End Equivalences. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_Equivalences. +Module Export HoTT_DOT_Basics_DOT_Trunc. +Module Export HoTT. +Module Export Basics. +Module Export Trunc. +Generalizable Variables A B m n f. + +Definition trunc_equiv A {B} (f : A -> B) + `{IsTrunc n A} `{IsEquiv A B f} + : IsTrunc n B. +admit. +Defined. + +Record TruncType (n : trunc_index) := BuildTruncType { + trunctype_type : Type ; + istrunc_trunctype_type : IsTrunc n trunctype_type +}. + +Arguments BuildTruncType _ _ {_}. + +Coercion trunctype_type : TruncType >-> Sortclass. + +Notation "n -Type" := (TruncType n) (at level 1) : type_scope. +Notation hProp := (-1)-Type. + +Notation BuildhProp := (BuildTruncType -1). + +End Trunc. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_Trunc. +Module Export HoTT_DOT_Types_DOT_Unit. +Module Export HoTT. +Module Export Types. +Module Export Unit. + +Notation unit_name x := (fun (_ : Unit) => x). + +End Unit. + +End Types. + +End HoTT. + +End HoTT_DOT_Types_DOT_Unit. +Module Export HoTT_DOT_Types_DOT_Sigma. +Module Export HoTT. +Module Export Types. +Module Export Sigma. +Local Open Scope path_scope. + +Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P) + (pq : {p : u.1 = v.1 & p # u.2 = v.2}) +: u = v + := match pq.2 in (_ = v2) return u = (v.1; v2) with + | 1 => match pq.1 as p in (_ = v1) return u = (v1; p # u.2) with + | 1 => 1 + end + end. + +Definition path_sigma {A : Type} (P : A -> Type) (u v : sigT P) + (p : u.1 = v.1) (q : p # u.2 = v.2) +: u = v + := path_sigma_uncurried P u v (p;q). + +Definition path_sigma' {A : Type} (P : A -> Type) {x x' : A} {y : P x} {y' : P x'} + (p : x = x') (q : p # y = y') +: (x;y) = (x';y') + := path_sigma P (x;y) (x';y') p q. + +Global Instance isequiv_pr1_contr {A} {P : A -> Type} + `{forall a, Contr (P a)} +: IsEquiv (@pr1 A P) | 100. +Proof. + refine (isequiv_adjointify (@pr1 A P) + (fun a => (a ; center (P a))) _ _). + - + intros a; reflexivity. + - + intros [a p]. + refine (path_sigma' P 1 (contr _)). +Defined. + +Definition path_sigma_hprop {A : Type} {P : A -> Type} + `{forall x, IsHProp (P x)} + (u v : sigT P) +: u.1 = v.1 -> u = v + := path_sigma_uncurried P u v o pr1^-1. + +End Sigma. + +End Types. + +End HoTT. + +End HoTT_DOT_Types_DOT_Sigma. +Module Export HoTT_DOT_Extensions. +Module Export HoTT. +Module Export Extensions. + +Section Extensions. + + Definition ExtensionAlong {A B : Type} (f : A -> B) + (P : B -> Type) (d : forall x:A, P (f x)) + := { s : forall y:B, P y & forall x:A, s (f x) = d x }. + + Fixpoint ExtendableAlong@{i j k l} + (n : nat) {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := match n with + | 0 => Unit@{l} + | S n => (forall (g : forall a, C (f a)), + ExtensionAlong@{i j k l l} f C g) * + forall (h k : forall b, C b), + ExtendableAlong n f (fun b => h b = k b) + end. + + Definition ooExtendableAlong@{i j k l} + {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := forall n, ExtendableAlong@{i j k l} n f C. + +End Extensions. + +End Extensions. + +End HoTT. + +End HoTT_DOT_Extensions. +Module Export HoTT. +Module Export Modalities. +Module Export ReflectiveSubuniverse. + +Module Type ReflectiveSubuniverses. + + Parameter ReflectiveSubuniverse@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). + + Parameter to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter inO_equiv_inO@{u a i j k} : + forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + + let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + In@{u a j} O U. + + Parameter hprop_inO@{u a i} + : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T). + + Parameter extendable_to_O@{u a i j k} + : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q}, + ooExtendableAlong@{i i j k} (to O P) (fun _ => Q). + +End ReflectiveSubuniverses. + +Module ReflectiveSubuniverses_Theory (Os : ReflectiveSubuniverses). +Export Os. + +Module Export Coercions. + + Coercion O_reflector : ReflectiveSubuniverse >-> Funclass. + +End Coercions. + +End ReflectiveSubuniverses_Theory. + +Module Type ReflectiveSubuniverses_Restriction_Data (Os : ReflectiveSubuniverses). + + Parameter New_ReflectiveSubuniverse@{u a} : Type2@{u a}. + + Parameter ReflectiveSubuniverses_restriction@{u a} + : New_ReflectiveSubuniverse@{u a} -> Os.ReflectiveSubuniverse@{u a}. + +End ReflectiveSubuniverses_Restriction_Data. + +Module ReflectiveSubuniverses_Restriction + (Os : ReflectiveSubuniverses) + (Res : ReflectiveSubuniverses_Restriction_Data Os) +<: ReflectiveSubuniverses. + + Definition ReflectiveSubuniverse := Res.New_ReflectiveSubuniverse. + + Definition O_reflector@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.O_reflector@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition In@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.In@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition O_inO@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.O_inO@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition to@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.to@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition inO_equiv_inO@{u a i j k} (O : ReflectiveSubuniverse@{u a}) + := Os.inO_equiv_inO@{u a i j k} (Res.ReflectiveSubuniverses_restriction O). + Definition hprop_inO@{u a i} (H : Funext) (O : ReflectiveSubuniverse@{u a}) + := Os.hprop_inO@{u a i} H (Res.ReflectiveSubuniverses_restriction O). + Definition extendable_to_O@{u a i j k} (O : ReflectiveSubuniverse@{u a}) + := @Os.extendable_to_O@{u a i j k} (Res.ReflectiveSubuniverses_restriction@{u a} O). + +End ReflectiveSubuniverses_Restriction. + +Module ReflectiveSubuniverses_FamUnion + (Os1 Os2 : ReflectiveSubuniverses) +<: ReflectiveSubuniverses. + + Definition ReflectiveSubuniverse@{u a} : Type2@{u a} + := Os1.ReflectiveSubuniverse@{u a} + Os2.ReflectiveSubuniverse@{u a}. + + Definition O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. +admit. +Defined. + + Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + Proof. + intros [O|O]; [ exact (Os1.In@{u a i} O) + | exact (Os2.In@{u a i} O) ]. + Defined. + + Definition O_inO@{u a i} + : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). +admit. +Defined. + + Definition to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. +admit. +Defined. + + Definition inO_equiv_inO@{u a i j k} : + forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + In@{u a j} O U. + Proof. + intros [O|O]; [ exact (Os1.inO_equiv_inO@{u a i j k} O) + | exact (Os2.inO_equiv_inO@{u a i j k} O) ]. + Defined. + + Definition hprop_inO@{u a i} + : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T). +admit. +Defined. + + Definition extendable_to_O@{u a i j k} + : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q}, + ooExtendableAlong@{i i j k} (to O P) (fun _ => Q). +admit. +Defined. + +End ReflectiveSubuniverses_FamUnion. + +End ReflectiveSubuniverse. + +End Modalities. + +End HoTT. + +Module Type Modalities. + + Parameter Modality@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : Modality@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter In@{u a i} : forall (O : Modality@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter O_inO@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). + + Parameter to@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter inO_equiv_inO@{u a i j k} : + forall (O : Modality@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + + let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + In@{u a j} O U. + + Parameter hprop_inO@{u a i} + : Funext -> forall (O : Modality@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T). + +End Modalities. + +Module Modalities_to_ReflectiveSubuniverses + (Os : Modalities) <: ReflectiveSubuniverses. + + Import Os. + + Fixpoint O_extendable@{u a i j k} (O : Modality@{u a}) + (A : Type@{i}) (B : O_reflector O A -> Type@{j}) + (B_inO : forall a, In@{u a j} O (B a)) (n : nat) + : ExtendableAlong@{i i j k} n (to O A) B. +admit. +Defined. + + Definition ReflectiveSubuniverse := Modality. + + Definition O_reflector := O_reflector. + + Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a} + := In@{u a i}. + Definition O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T) + := O_inO@{u a i}. + Definition to := to. + Definition inO_equiv_inO@{u a i j k} : + forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + In@{u a j} O U + := inO_equiv_inO@{u a i j k}. + Definition hprop_inO@{u a i} + : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T) + := hprop_inO@{u a i}. + + Definition extendable_to_O@{u a i j k} (O : ReflectiveSubuniverse@{u a}) + {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q} + : ooExtendableAlong@{i i j k} (to O P) (fun _ => Q) + := fun n => O_extendable O P (fun _ => Q) (fun _ => Q_inO) n. + +End Modalities_to_ReflectiveSubuniverses. + +Module Type EasyModalities. + + Parameter Modality@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : Modality@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter to@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter minO_pathsO@{u a i} + : forall (O : Modality@{u a}) (A : Type@{i}) + (z z' : O_reflector@{u a i} O A), + IsEquiv (to@{u a i} O (z = z')). + +End EasyModalities. + +Module EasyModalities_to_Modalities (Os : EasyModalities) +<: Modalities. + + Import Os. + + Definition Modality := Modality. + + Definition O_reflector@{u a i} := O_reflector@{u a i}. + Definition to@{u a i} := to@{u a i}. + + Definition In@{u a i} + : forall (O : Modality@{u a}), Type@{i} -> Type@{i} + := fun O A => IsEquiv@{i i} (to O A). + + Definition hprop_inO@{u a i} `{Funext} (O : Modality@{u a}) + (T : Type@{i}) + : IsHProp (In@{u a i} O T). +admit. +Defined. + + Definition O_ind_internal@{u a i j k} (O : Modality@{u a}) + (A : Type@{i}) (B : O_reflector@{u a i} O A -> Type@{j}) + (B_inO : forall oa, In@{u a j} O (B oa)) + : let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + (forall a, B (to O A a)) -> forall oa, B oa. +admit. +Defined. + + Definition O_ind_beta_internal@{u a i j k} (O : Modality@{u a}) + (A : Type@{i}) (B : O_reflector@{u a i} O A -> Type@{j}) + (B_inO : forall oa, In@{u a j} O (B oa)) + (f : forall a : A, B (to O A a)) (a:A) + : O_ind_internal@{u a i j k} O A B B_inO f (to O A a) = f a. +admit. +Defined. + + Definition O_inO@{u a i} (O : Modality@{u a}) (A : Type@{i}) + : In@{u a i} O (O_reflector@{u a i} O A). +admit. +Defined. + + Definition inO_equiv_inO@{u a i j k} (O : Modality@{u a}) (A : Type@{i}) (B : Type@{j}) + (A_inO : In@{u a i} O A) (f : A -> B) (feq : IsEquiv f) + : In@{u a j} O B. + Proof. + simple refine (isequiv_commsq (to O A) (to O B) f + (O_ind_internal O A (fun _ => O_reflector O B) _ (fun a => to O B (f a))) _). + - + intros; apply O_inO. + - + intros a; refine (O_ind_beta_internal@{u a i j k} O A (fun _ => O_reflector O B) _ _ a). + - + apply A_inO. + - + simple refine (isequiv_adjointify _ + (O_ind_internal O B (fun _ => O_reflector O A) _ (fun b => to O A (f^-1 b))) _ _); + intros x. + + + apply O_inO. + + + pattern x; refine (O_ind_internal O B _ _ _ x); intros. + * + apply minO_pathsO. + * + simpl; admit. + + + pattern x; refine (O_ind_internal O A _ _ _ x); intros. + * + apply minO_pathsO. + * + simpl; admit. + Defined. + +End EasyModalities_to_Modalities. + +Module Modalities_Theory (Os : Modalities). + +Export Os. +Module Export Os_ReflectiveSubuniverses + := Modalities_to_ReflectiveSubuniverses Os. +Module Export RSU + := ReflectiveSubuniverses_Theory Os_ReflectiveSubuniverses. + +Module Export Coercions. + Coercion modality_to_reflective_subuniverse + := idmap : Modality -> ReflectiveSubuniverse. +End Coercions. + +Class IsConnected (O : Modality@{u a}) (A : Type@{i}) + + := isconnected_contr_O : IsTrunc@{i} -2 (O A). + +Class IsConnMap (O : Modality@{u a}) + {A : Type@{i}} {B : Type@{j}} (f : A -> B) + := isconnected_hfiber_conn_map + + : forall b:B, IsConnected@{u a k} O (hfiber@{i j} f b). + +End Modalities_Theory. + +Private Inductive Trunc (n : trunc_index) (A :Type) : Type := + tr : A -> Trunc n A. +Arguments tr {n A} a. + +Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i}) +: IsTrunc@{j} n (Trunc@{i} n A). +Admitted. + +Definition Trunc_ind {n A} + (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)} + : (forall a, P (tr a)) -> (forall aa, P aa) +:= (fun f aa => match aa with tr a => fun _ => f a end Pt). + +Definition Truncation_Modality := trunc_index. + +Module Truncation_Modalities <: Modalities. + + Definition Modality : Type2@{u a} := Truncation_Modality. + + Definition O_reflector (n : Modality@{u u'}) A := Trunc n A. + + Definition In (n : Modality@{u u'}) A := IsTrunc n A. + + Definition O_inO (n : Modality@{u u'}) A : In n (O_reflector n A). +admit. +Defined. + + Definition to (n : Modality@{u u'}) A := @tr n A. + + Definition inO_equiv_inO (n : Modality@{u u'}) + (A : Type@{i}) (B : Type@{j}) Atr f feq + : let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + In n B + := @trunc_equiv A B f n Atr feq. + + Definition hprop_inO `{Funext} (n : Modality@{u u'}) A + : IsHProp (In n A). +admit. +Defined. + +End Truncation_Modalities. + +Module Import TrM := Modalities_Theory Truncation_Modalities. + +Definition merely (A : Type@{i}) : hProp@{i} := BuildhProp (Trunc -1 A). + +Notation IsSurjection := (IsConnMap -1). + +Definition BuildIsSurjection {A B} (f : A -> B) : + (forall b, merely (hfiber f b)) -> IsSurjection f. +admit. +Defined. + +Ltac strip_truncations := + + progress repeat match goal with + | [ T : _ |- _ ] + => revert_opaque T; + refine (@Trunc_ind _ _ _ _ _); + + []; + intro T + end. +Local Open Scope trunc_scope. + +Global Instance conn_pointed_type {n : trunc_index} {A : Type} (a0:A) + `{IsConnMap n _ _ (unit_name a0)} : IsConnected n.+1 A | 1000. +admit. +Defined. + +Definition loops (A : pType) : pType := + Build_pType (point A = point A) idpath. + +Record pMap (A B : pType) := + { pointed_fun : A -> B ; + point_eq : pointed_fun (point A) = point B }. + +Arguments point_eq {A B} f : rename. +Coercion pointed_fun : pMap >-> Funclass. + +Infix "->*" := pMap (at level 99) : pointed_scope. +Local Open Scope pointed_scope. + +Definition pmap_compose {A B C : pType} + (g : B ->* C) (f : A ->* B) +: A ->* C + := Build_pMap A C (g o f) + (ap g (point_eq f) @ point_eq g). + +Record pHomotopy {A B : pType} (f g : pMap A B) := + { pointed_htpy : f == g ; + point_htpy : pointed_htpy (point A) @ point_eq g = point_eq f }. +Arguments pointed_htpy {A B f g} p x. + +Infix "==*" := pHomotopy (at level 70, no associativity) : pointed_scope. + +Definition loops_functor {A B : pType} (f : A ->* B) +: (loops A) ->* (loops B). +Proof. + refine (Build_pMap (loops A) (loops B) + (fun p => (point_eq f)^ @ (ap f p @ point_eq f)) _). + apply moveR_Vp; simpl. + refine (concat_1p _ @ (concat_p1 _)^). +Defined. + +Definition loops_functor_compose {A B C : pType} + (g : B ->* C) (f : A ->* B) +: (loops_functor (pmap_compose g f)) + ==* (pmap_compose (loops_functor g) (loops_functor f)). +admit. +Defined. + +Local Open Scope path_scope. + +Record ooGroup := + { classifying_space : pType@{i} ; + isconn_classifying_space : IsConnected@{u a i} 0 classifying_space + }. + +Local Notation B := classifying_space. + +Definition group_type (G : ooGroup) : Type + := point (B G) = point (B G). + +Coercion group_type : ooGroup >-> Sortclass. + +Definition group_loops (X : pType) +: ooGroup. +Proof. + + pose (x0 := point X); + pose (BG := (Build_pType + { x:X & merely (x = point X) } + (existT (fun x:X => merely (x = point X)) x0 (tr 1)))). + + cut (IsConnected 0 BG). + { + exact (Build_ooGroup BG). +} + cut (IsSurjection (unit_name (point BG))). + { + intros; refine (conn_pointed_type (point _)). +} + apply BuildIsSurjection; simpl; intros [x p]. + strip_truncations; apply tr; exists tt. + apply path_sigma_hprop; simpl. + exact (p^). +Defined. + +Definition loops_group (X : pType) +: loops X <~> group_loops X. +admit. +Defined. + +Definition ooGroupHom (G H : ooGroup) + := pMap (B G) (B H). + +Definition grouphom_fun {G H} (phi : ooGroupHom G H) : G -> H + := loops_functor phi. + +Coercion grouphom_fun : ooGroupHom >-> Funclass. + +Definition group_loops_functor + {X Y : pType} (f : pMap X Y) +: ooGroupHom (group_loops X) (group_loops Y). +Proof. + simple refine (Build_pMap _ _ _ _); simpl. + - + intros [x p]. + exists (f x). + strip_truncations; apply tr. + exact (ap f p @ point_eq f). + - + apply path_sigma_hprop; simpl. + apply point_eq. +Defined. + +Definition loops_functor_group + {X Y : pType} (f : pMap X Y) +: loops_functor (group_loops_functor f) o loops_group X + == loops_group Y o loops_functor f. +admit. +Defined. + +Definition grouphom_compose {G H K : ooGroup} + (psi : ooGroupHom H K) (phi : ooGroupHom G H) +: ooGroupHom G K + := pmap_compose psi phi. + +Definition group_loops_functor_compose + {X Y Z : pType} + (psi : pMap Y Z) (phi : pMap X Y) +: grouphom_compose (group_loops_functor psi) (group_loops_functor phi) + == group_loops_functor (pmap_compose psi phi). +Proof. + intros g. + unfold grouphom_fun, grouphom_compose. + refine (pointed_htpy (loops_functor_compose _ _) g @ _). + pose (p := eisretr (loops_group X) g). + change (loops_functor (group_loops_functor psi) + (loops_functor (group_loops_functor phi) g) + = loops_functor (group_loops_functor + (pmap_compose psi phi)) g). + rewrite <- p. + Fail Timeout 1 Time rewrite !loops_functor_group. + (* 0.004 s in 8.5rc1, 8.677 s in 8.5 *) + Timeout 1 do 3 rewrite loops_functor_group. +Abort. \ No newline at end of file diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index 5b0502cf1a..b88c142be1 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -58,4 +58,5 @@ Qed. Lemma test b : b && true = b. Fail rewrite andb_true_l. - Admitted. \ No newline at end of file + Admitted. + \ No newline at end of file -- cgit v1.2.3 From b1e6542af576dc92221c4b4eb3e4c547b5901950 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 9 Mar 2016 16:34:35 +0100 Subject: Fixed bug #4533 with previous Keyed Unification commit Add test-suite file to ensure non-regression. --- test-suite/bugs/closed/4533.v | 224 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 224 insertions(+) create mode 100644 test-suite/bugs/closed/4533.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4533.v b/test-suite/bugs/closed/4533.v new file mode 100644 index 0000000000..217ea8a4c7 --- /dev/null +++ b/test-suite/bugs/closed/4533.v @@ -0,0 +1,224 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." +"Top" "-top" "bug_lex_wrong_rewrite_02") -*- *) +(* File reduced by coq-bug-finder from original input, then from 1125 lines to +346 lines, then from 360 lines to 346 lines, then from 822 lines to 271 lines, +then from 285 lines to 271 lines *) +(* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml +4.01.0 + coqtop version 8.5 (January 2016) *) +Inductive False := . +Axiom proof_admitted : False. +Tactic Notation "admit" := case proof_admitted. +Require Coq.Init.Datatypes. +Import Coq.Init.Notations. +Global Set Universe Polymorphism. +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Module Export Datatypes. + Set Implicit Arguments. + Notation nat := Coq.Init.Datatypes.nat. + Notation S := Coq.Init.Datatypes.S. + Record prod (A B : Type) := pair { fst : A ; snd : B }. + Notation "x * y" := (prod x y) : type_scope. + Delimit Scope nat_scope with nat. + Open Scope nat_scope. +End Datatypes. +Module Export Specif. + Set Implicit Arguments. + Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P +proj1_sig }. + Notation sigT := sig (only parsing). + Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + Notation projT1 := proj1_sig (only parsing). + Notation projT2 := proj2_sig (only parsing). +End Specif. +Global Set Keyed Unification. +Global Unset Strict Universe Declaration. +Definition Type1@{i} := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. +Definition Type2@{i j} := Eval hnf in let gt := (Type1@{j} : Type@{i}) in +Type@{i}. +Definition Type2le@{i j} := Eval hnf in let gt := (Set : Type@{i}) in + let ge := ((fun x => x) : Type1@{j} -> +Type@{i}) in Type@{i}. +Notation idmap := (fun x => x). +Delimit Scope function_scope with function. +Delimit Scope path_scope with path. +Delimit Scope fibration_scope with fibration. +Open Scope fibration_scope. +Open Scope function_scope. +Notation pr1 := projT1. +Notation pr2 := projT2. +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. +Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. +Notation compose := (fun g f x => g (f x)). +Notation "g 'o' f" := (compose g%function f%function) (at level 40, left +associativity) : function_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. +Notation "1" := idpath : path_scope. +Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope. +Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) + := forall x:A, f x = g x. +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : +type_scope. +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr +(f x) = ap f (eissect x) + }. +Arguments eissect {A B}%type_scope f%function_scope {_} _. +Inductive Unit : Type1 := tt : Unit. +Local Open Scope path_scope. +Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z += t) : + p @ (q @ r) = (p @ q) @ r := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. +Section Adjointify. + Context {A B : Type} (f : A -> B) (g : B -> A). + Context (isretr : Sect g f) (issect : Sect f g). + Let issect' := fun x => + ap g (ap f (issect x)^) @ ap g (isretr (f x)) @ issect x. + + Let is_adjoint' (a : A) : isretr (f a) = ap f (issect' a). + admit. + Defined. + + Definition isequiv_adjointify : IsEquiv f + := BuildIsEquiv A B f g isretr issect' is_adjoint'. +End Adjointify. +Definition ExtensionAlong {A B : Type} (f : A -> B) + (P : B -> Type) (d : forall x:A, P (f x)) + := { s : forall y:B, P y & forall x:A, s (f x) = d x }. +Fixpoint ExtendableAlong@{i j k l} + (n : nat) {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := match n with + | 0 => Unit@{l} + | S n => (forall (g : forall a, C (f a)), + ExtensionAlong@{i j k l l} f C g) * + forall (h k : forall b, C b), + ExtendableAlong n f (fun b => h b = k b) + end. + +Definition ooExtendableAlong@{i j k l} + {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := forall n, ExtendableAlong@{i j k l} n f C. + +Module Type ReflectiveSubuniverses. + + Parameter ReflectiveSubuniverse@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : +Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). + + Parameter to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : +Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter extendable_to_O@{u a i j k} + : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : +Type2le@{j a}} {Q_inO : In@{u a j} O Q}, + ooExtendableAlong@{i i j k} (to O P) (fun _ => Q). + +End ReflectiveSubuniverses. + +Module ReflectiveSubuniverses_Theory (Os : ReflectiveSubuniverses). + Export Os. + Existing Class In. + Module Export Coercions. + Coercion O_reflector : ReflectiveSubuniverse >-> Funclass. + End Coercions. + Global Existing Instance O_inO. + + Section ORecursion. + Context {O : ReflectiveSubuniverse}. + + Definition O_rec {P Q : Type} {Q_inO : In O Q} + (f : P -> Q) + : O P -> Q + := (fst (extendable_to_O O 1%nat) f).1. + + Definition O_rec_beta {P Q : Type} {Q_inO : In O Q} + (f : P -> Q) (x : P) + : O_rec f (to O P x) = f x + := (fst (extendable_to_O O 1%nat) f).2 x. + + Definition O_indpaths {P Q : Type} {Q_inO : In O Q} + (g h : O P -> Q) (p : g o to O P == h o to O P) + : g == h + := (fst (snd (extendable_to_O O 2) g h) p).1. + + End ORecursion. + + + Section Reflective_Subuniverse. + Context (O : ReflectiveSubuniverse@{Ou Oa}). + + Definition isequiv_to_O_inO@{u a i} (T : Type@{i}) `{In@{u a i} O T} : +IsEquiv@{i i} (to O T). + Proof. + + pose (g := O_rec@{u a i i i i i} idmap). + refine (isequiv_adjointify (to O T) g _ _). + - + refine (O_indpaths@{u a i i i i i} (to O T o g) idmap _). + intros x. + apply ap. + apply O_rec_beta. + - + intros x. + apply O_rec_beta. + Defined. + Global Existing Instance isequiv_to_O_inO. + + End Reflective_Subuniverse. + +End ReflectiveSubuniverses_Theory. + +Module Type Preserves_Fibers (Os : ReflectiveSubuniverses). + Module Export Os_Theory := ReflectiveSubuniverses_Theory Os. +End Preserves_Fibers. + +Module Lex_Reflective_Subuniverses + (Os : ReflectiveSubuniverses) (Opf : Preserves_Fibers Os). + Import Opf. + Goal forall (O : ReflectiveSubuniverse) (A : Type) (B : A -> Type) (A_inO : +In O A), + + forall g, + forall (x : O {x : A & B x}) v v' v'' (p2 : v'' = v') (p0 : v' = v) (p1 : +v = _) r, + (p2 + @ (p0 + @ p1)) + @ eissect (to O A) (g x) = r. + intros. + cbv zeta. + rewrite concat_p_pp. + match goal with + | [ |- p2 @ p0 @ p1 @ eissect (to O A) (g x) = r ] => idtac "good" + | [ |- ?G ] => fail 1 "bad" G + end. \ No newline at end of file -- cgit v1.2.3 From 2788c86e6a3c089aa7450a7768f8444470e35901 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 9 Mar 2016 17:11:46 +0100 Subject: Fix test-suite file coq-prog-args They were not parsed correctly with a newline in the middle. --- test-suite/bugs/closed/4533.v | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4533.v b/test-suite/bugs/closed/4533.v index 217ea8a4c7..ae17fb145d 100644 --- a/test-suite/bugs/closed/4533.v +++ b/test-suite/bugs/closed/4533.v @@ -1,5 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." -"Top" "-top" "bug_lex_wrong_rewrite_02") -*- *) +(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." "Top" "-top" "bug_lex_wrong_rewrite_02") -*- *) (* File reduced by coq-bug-finder from original input, then from 1125 lines to 346 lines, then from 360 lines to 346 lines, then from 822 lines to 271 lines, then from 285 lines to 271 lines *) @@ -12,6 +11,7 @@ Tactic Notation "admit" := case proof_admitted. Require Coq.Init.Datatypes. Import Coq.Init.Notations. Global Set Universe Polymorphism. +Global Set Primitive Projections. Notation "A -> B" := (forall (_ : A), B) : type_scope. Module Export Datatypes. Set Implicit Arguments. @@ -202,6 +202,7 @@ Module Type Preserves_Fibers (Os : ReflectiveSubuniverses). Module Export Os_Theory := ReflectiveSubuniverses_Theory Os. End Preserves_Fibers. +Opaque eissect. Module Lex_Reflective_Subuniverses (Os : ReflectiveSubuniverses) (Opf : Preserves_Fibers Os). Import Opf. @@ -221,4 +222,5 @@ v = _) r, match goal with | [ |- p2 @ p0 @ p1 @ eissect (to O A) (g x) = r ] => idtac "good" | [ |- ?G ] => fail 1 "bad" G - end. \ No newline at end of file + end. + Fail rewrite concat_p_pp. \ No newline at end of file -- cgit v1.2.3 From 4341f37cf3c51ed82c23f05846c8e6e8823d3cd6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 10 Mar 2016 19:02:16 +0100 Subject: Primitive projections: protect kernel from erroneous definitions. E.g., Inductive foo := mkFoo { bla : foo } allowed to define recursive records with eta for which conversion is incomplete. - Eta-conversion only applies to BiFinite inductives - Finiteness information is now checked by the kernel (the constructor types must be strictly non recursive for BiFinite declarations). --- test-suite/success/primitiveproj.v | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) (limited to 'test-suite') diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v index 281d707cb3..b5e6ccd618 100644 --- a/test-suite/success/primitiveproj.v +++ b/test-suite/success/primitiveproj.v @@ -35,10 +35,6 @@ Set Implicit Arguments. Check nat. -(* Inductive X (U:Type) := Foo (k : nat) (x : X U). *) -(* Parameter x : X nat. *) -(* Check x.(k). *) - Inductive X (U:Type) := { k : nat; a: k = k -> X U; b : let x := a eq_refl in X U }. Parameter x:X nat. @@ -49,18 +45,8 @@ Inductive Y := { next : option Y }. Check _.(next) : option Y. Lemma eta_ind (y : Y) : y = Build_Y y.(next). -Proof. reflexivity. Defined. - -Variable t : Y. - -Fixpoint yn (n : nat) (y : Y) : Y := - match n with - | 0 => t - | S n => {| next := Some (yn n y) |} - end. +Proof. Fail reflexivity. Abort. -Lemma eta_ind' (y: Y) : Some (yn 100 y) = Some {| next := (yn 100 y).(next) |}. -Proof. reflexivity. Defined. (* -- cgit v1.2.3 From e9bf68016ce9e04feb63222ff4bbafd27531f564 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 11 Mar 2016 10:32:14 +0100 Subject: According to Bruno, my fix for #4588 seems to be enough. So adding a test-suite file and closing the bug. --- test-suite/bugs/closed/4588.v | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 test-suite/bugs/closed/4588.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4588.v b/test-suite/bugs/closed/4588.v new file mode 100644 index 0000000000..ff66277e03 --- /dev/null +++ b/test-suite/bugs/closed/4588.v @@ -0,0 +1,10 @@ +Set Primitive Projections. + +(* This proof was accepted in Coq 8.5 because the subterm specs were not +projected correctly *) +Inductive foo : Prop := mkfoo { proj1 : False -> foo; proj2 : (forall P : Prop, P -> P) }. + +Fail Fixpoint loop (x : foo) : False := + loop (proj2 x _ x). + +Fail Definition bad : False := loop (mkfoo (fun x => match x with end) (fun _ x => x)). -- cgit v1.2.3 From 04b7394eaae170685a09ccd85ef47991466e6681 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 12 Mar 2016 13:40:16 +0100 Subject: Adding a file summarizing the inconsistencies in interpreting implicit arguments and scopes with abbreviations and notations. Comments are welcome on the proposed solutions for uniformization. --- test-suite/success/Notations2.v | 90 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) create mode 100644 test-suite/success/Notations2.v (limited to 'test-suite') diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v new file mode 100644 index 0000000000..ac41819f56 --- /dev/null +++ b/test-suite/success/Notations2.v @@ -0,0 +1,90 @@ +(* This file is giving some examples about how implicit arguments and + scopes are (inconsistently) treated when using abbreviations or + notations, in terms or patterns, or when using @ and parentheses in + terms and patterns *) + +(* One compromise would be that: + - Neither abbreviations nor notations break implicit arguments and + scopes unless the head constant is with @ and surrounded with parentheses. + + This would change 3. terms and patterns to behave like 4. terms, + with former behavior possible by using instead (@pair' _ x%nat) + or (pair' x%nat). + + This would change 4. patterns to behave like 4. terms, introducing the + possibibility to have the deactivation in patterns, as it is in terms, + by using (@pair'). + + This would change 5. terms to behave like 5. patterns, introducing the + possibibility to have the activation behavior in terms, as it with + abbreviations, using either (@(pair') _ x%nat) or (pair' _ x). + + This would change 6. patterns to behave like 6. terms, introducing the + possibibility to have the deactivation behavior in patterns, as it with + abbreviations in terms, using either (@(pair') _ x%nat) or (pair' _ x). + - "(foo args)" directly in terms would still deactivation implicit + arguments and scopes for further arguments, as of today. + - "(@foo args)" directly in terms would deactivate implicit arguments and scopes + in args as of today, but not for further arguments, on the contrary of today + - "((@foo) args)" directly in terms would deactivate implicit + arguments and scopes in args and for further arguments, as it is today + + Then, in both terms and patterns: + - "(@foo args)" in an abbreviation or notation would behave the same as + "(@foo args)" when expanded, i.e. with deactivation of implicit arguments + and scopes only for args, but not for further arguments. + - "((@foo) args)" in an abbreviation or notation would behave the same as + "((@foo) args)" when expanded, i.e. with deactivation of implicit arguments and scopes. + - "(foo args)" in an abbreviation or notation would behave the same as + "foo args" when expanded, i.e. with no change on implicit arguments and scopes. +*) + +Inductive prod' A : Type -> Type := +| pair' (a:A) B (b:B) (c:bool) : prod' A B. +Arguments pair' [A] a%bool_scope [B] b%bool_scope c%bool_scope. +Notation "0" := true : bool_scope. + +(* 1. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c1 x := (pair' x). +Check pair' 0 0 0 : prod' bool bool. +Check (pair' 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) +Check c1 0 0 0 : prod' bool bool. +Check fun x : prod' bool bool => match x with c1 0 y 0 => 2 | _ => 1 end. +Check fun x : prod' bool bool => match x with (pair' 0) y 0 => 2 | _ => 1 end. (* Inconsistent with terms *) + +(* 2. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c2 x := (@pair' _ x). +Check (@pair' _ 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) +Check c2 0 0 0 : prod' bool bool. +Check fun A (x : prod' bool A) => match x with c2 0 y 0 => 2 | _ => 1 end. +Check fun A (x : prod' bool A) => match x with (@pair' _ 0) y 0 => 2 | _ => 1 end. (* Inconsistent with terms *) + +(* 3. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c3 x := ((@pair') _ x). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. (* @ is blocking implicit and scopes *) +Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. (* parentheses and @ are blocking implicit and scopes *) +Check c3 0 0 0 : prod' nat bool. (* First scope is blocked but not the last two scopes *) +Check fun A (x :prod' nat A) => match x with c3 0 y 0 => 2 | _ => 1 end. +(* Check fun A (x :prod' nat A) => match x with ((@pair') _ 0) y 0 => 2 | _ => 1 end.*) + +(* 4. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +(* unless an atomic @ is given, in terms but not in patterns *) +Notation c4 := (@pair'). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check c4 _ 0 _ 0 0%bool : prod' nat nat. (* all 0 are in nat_scope: would there be incompatibilities to change that? *) +Check fun A (x :prod' bool A) => match x with c4 _ 0 _ y 0 => 2 | _ => 1 end. (* Inconsistent with terms: both 0 are in bool_scope *) +Check fun A (x :prod' nat A) => match x with (@pair') _ 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: the implicit arguments and scopes are not deactivated *) + +(* 5. Notations stop further implicit arguments to be inserted and scopes to be used *) +(* in terms but not in patterns *) +Notation "% x" := (pair' x) (at level 0, x at level 0). +Check pair' 0 0 0 : prod' bool bool. +Check % 0 _ 0 0%bool : prod' bool nat. (* last two 0 are in nat_scope *) +Check fun A (x :prod' bool A) => match x with % 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: both 0 are in bool_scope *) +Check fun A (x :prod' bool A) => match x with pair' 0 y 0 => 2 | _ => 1 end. + +(* 6. Notations stop further implicit arguments to be inserted and scopes to be used *) +(* in terms but not in patterns *) +Notation "% x" := ((@pair') _ x%nat) (at level 0, x at level 0). +Check (@pair') _ 0 _ 0%bool 0%bool : prod' nat bool. +Check ((@pair') _ 0) _ 0%bool 0%bool : prod' nat bool. +Check % 0 _ 0 0%bool : prod' nat nat. (* last two 0 are in nat_scope *) +Check fun A (x :prod' nat A) => match x with % 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: last 0 is in bool_scope, and implicit is not given *) +Check fun A (x :prod' bool A) => match x with (@pair') 0 y 0 => 2 | _ => 1 end. (* inconsistent with terms: the implicit arguments and scopes are not deactivated *) +Check fun A (x :prod' nat A) => match x with ((@pair') _) 0 y 0 => 2 | _ => 1 end. -- cgit v1.2.3 From 3366f05ab09aa90dcc96d7432bff09617162c3e4 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sun, 13 Mar 2016 17:49:25 +0100 Subject: Adopting the same rules for interpreting @, abbreviations and notations in patterns than in terms, wrt implicit arguments and scopes. See file Notations2.v for the conventions in use in terms. Somehow this could be put in 8.5 since it puts in agreement the interpretation of abbreviations and notations in "symmetric patterns" to what is done in terms (even though the interpretation rules for terms are a bit ad hoc). There is one exception: in terms, "(foo args) args'" deactivates the implicit arguments and scopes in args'. This is a bit complicated to implement in patterns so the syntax is not supported (and anyway, this convention is a bit questionable). --- test-suite/success/Notations2.v | 110 ++++++++++++++++++++-------------------- 1 file changed, 56 insertions(+), 54 deletions(-) (limited to 'test-suite') diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v index ac41819f56..9505a56e3f 100644 --- a/test-suite/success/Notations2.v +++ b/test-suite/success/Notations2.v @@ -1,40 +1,33 @@ (* This file is giving some examples about how implicit arguments and - scopes are (inconsistently) treated when using abbreviations or - notations, in terms or patterns, or when using @ and parentheses in - terms and patterns *) - -(* One compromise would be that: - - Neither abbreviations nor notations break implicit arguments and - scopes unless the head constant is with @ and surrounded with parentheses. - + This would change 3. terms and patterns to behave like 4. terms, - with former behavior possible by using instead (@pair' _ x%nat) - or (pair' x%nat). - + This would change 4. patterns to behave like 4. terms, introducing the - possibibility to have the deactivation in patterns, as it is in terms, - by using (@pair'). - + This would change 5. terms to behave like 5. patterns, introducing the - possibibility to have the activation behavior in terms, as it with - abbreviations, using either (@(pair') _ x%nat) or (pair' _ x). - + This would change 6. patterns to behave like 6. terms, introducing the - possibibility to have the deactivation behavior in patterns, as it with - abbreviations in terms, using either (@(pair') _ x%nat) or (pair' _ x). - - "(foo args)" directly in terms would still deactivation implicit - arguments and scopes for further arguments, as of today. - - "(@foo args)" directly in terms would deactivate implicit arguments and scopes - in args as of today, but not for further arguments, on the contrary of today - - "((@foo) args)" directly in terms would deactivate implicit - arguments and scopes in args and for further arguments, as it is today - - Then, in both terms and patterns: - - "(@foo args)" in an abbreviation or notation would behave the same as - "(@foo args)" when expanded, i.e. with deactivation of implicit arguments - and scopes only for args, but not for further arguments. - - "((@foo) args)" in an abbreviation or notation would behave the same as - "((@foo) args)" when expanded, i.e. with deactivation of implicit arguments and scopes. - - "(foo args)" in an abbreviation or notation would behave the same as - "foo args" when expanded, i.e. with no change on implicit arguments and scopes. + scopes are treated when using abbreviations or notations, in terms + or patterns, or when using @ and parentheses in terms and patterns. + +The convention is: + +Constant foo with implicit arguments and scopes used in a term or a pattern: + + foo do not deactivate further arguments and scopes + @foo deactivates further arguments and scopes + (foo x) deactivates further arguments and scopes + (@foo x) deactivates further arguments and scopes + +Notations binding to foo: + +# := foo do not deactivate further arguments and scopes +# := @foo deactivates further arguments and scopes +# x := foo x deactivates further arguments and scopes +# x := @foo x deactivates further arguments and scopes + +Abbreviations binding to foo: + +f := foo do not deactivate further arguments and scopes +f := @foo deactivates further arguments and scopes +f x := foo x do not deactivate further arguments and scopes +f x := @foo x do not deactivate further arguments and scopes *) +(* One checks that abbreviations and notations in patterns now behave like in terms *) + Inductive prod' A : Type -> Type := | pair' (a:A) B (b:B) (c:bool) : prod' A B. Arguments pair' [A] a%bool_scope [B] b%bool_scope c%bool_scope. @@ -46,14 +39,13 @@ Check pair' 0 0 0 : prod' bool bool. Check (pair' 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) Check c1 0 0 0 : prod' bool bool. Check fun x : prod' bool bool => match x with c1 0 y 0 => 2 | _ => 1 end. -Check fun x : prod' bool bool => match x with (pair' 0) y 0 => 2 | _ => 1 end. (* Inconsistent with terms *) (* 2. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) Notation c2 x := (@pair' _ x). Check (@pair' _ 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) Check c2 0 0 0 : prod' bool bool. Check fun A (x : prod' bool A) => match x with c2 0 y 0 => 2 | _ => 1 end. -Check fun A (x : prod' bool A) => match x with (@pair' _ 0) y 0 => 2 | _ => 1 end. (* Inconsistent with terms *) +Check fun A (x : prod' bool A) => match x with (@pair' _ 0) _ y 0%bool => 2 | _ => 1 end. (* 3. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) Notation c3 x := ((@pair') _ x). @@ -61,30 +53,40 @@ Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. (* @ is blocking impl Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. (* parentheses and @ are blocking implicit and scopes *) Check c3 0 0 0 : prod' nat bool. (* First scope is blocked but not the last two scopes *) Check fun A (x :prod' nat A) => match x with c3 0 y 0 => 2 | _ => 1 end. -(* Check fun A (x :prod' nat A) => match x with ((@pair') _ 0) y 0 => 2 | _ => 1 end.*) (* 4. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) -(* unless an atomic @ is given, in terms but not in patterns *) +(* unless an atomic @ is given *) Notation c4 := (@pair'). Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. -Check c4 _ 0 _ 0 0%bool : prod' nat nat. (* all 0 are in nat_scope: would there be incompatibilities to change that? *) -Check fun A (x :prod' bool A) => match x with c4 _ 0 _ y 0 => 2 | _ => 1 end. (* Inconsistent with terms: both 0 are in bool_scope *) -Check fun A (x :prod' nat A) => match x with (@pair') _ 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: the implicit arguments and scopes are not deactivated *) +Check c4 _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with c4 _ 0%bool _ y 0%bool => 2 | _ => 1 end. +Check fun A (x :prod' bool A) => match x with (@pair') _ 0%bool _ y 0%bool => 2 | _ => 1 end. (* 5. Notations stop further implicit arguments to be inserted and scopes to be used *) -(* in terms but not in patterns *) -Notation "% x" := (pair' x) (at level 0, x at level 0). +Notation "# x" := (pair' x) (at level 0, x at level 1). Check pair' 0 0 0 : prod' bool bool. -Check % 0 _ 0 0%bool : prod' bool nat. (* last two 0 are in nat_scope *) -Check fun A (x :prod' bool A) => match x with % 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: both 0 are in bool_scope *) -Check fun A (x :prod' bool A) => match x with pair' 0 y 0 => 2 | _ => 1 end. +Check # 0 _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with # 0 _ y 0%bool => 2 | _ => 1 end. (* 6. Notations stop further implicit arguments to be inserted and scopes to be used *) -(* in terms but not in patterns *) -Notation "% x" := ((@pair') _ x%nat) (at level 0, x at level 0). -Check (@pair') _ 0 _ 0%bool 0%bool : prod' nat bool. -Check ((@pair') _ 0) _ 0%bool 0%bool : prod' nat bool. -Check % 0 _ 0 0%bool : prod' nat nat. (* last two 0 are in nat_scope *) -Check fun A (x :prod' nat A) => match x with % 0 y 0 => 2 | _ => 1 end. (* Inconsistent with terms: last 0 is in bool_scope, and implicit is not given *) -Check fun A (x :prod' bool A) => match x with (@pair') 0 y 0 => 2 | _ => 1 end. (* inconsistent with terms: the implicit arguments and scopes are not deactivated *) -Check fun A (x :prod' nat A) => match x with ((@pair') _) 0 y 0 => 2 | _ => 1 end. +Notation "## x" := ((@pair') _ x) (at level 0, x at level 1). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. +Check ## 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ## 0%bool _ y 0%bool => 2 | _ => 1 end. + +(* 7. Notations stop further implicit arguments to be inserted and scopes to be used *) +Notation "###" := (@pair') (at level 0). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check ### _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ### _ 0%bool _ y 0%bool => 2 | _ => 1 end. + +(* 8. Notations w/o @ preserves implicit arguments and scopes *) +Notation "####" := pair' (at level 0). +Check #### 0 0 0 : prod' bool bool. +Check fun A (x :prod' bool A) => match x with #### 0 y 0 => 2 | _ => 1 end. + +(* 9. Notations w/o @ but arguments do not preserve further implicit arguments and scopes *) +Notation "##### x" := (pair' x) (at level 0, x at level 1). +Check ##### 0 _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ##### 0 _ y 0%bool => 2 | _ => 1 end. -- cgit v1.2.3 From 779fd5d9a4982b19fd257b61f444ae8e6155dcbe Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 14 Mar 2016 19:50:29 +0100 Subject: Fix bug when a sort is ascribed to a Record Forcefully equating it to the inferred level is not always desirable or possible. --- test-suite/success/univers.v | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v index e00701fb68..269359ae62 100644 --- a/test-suite/success/univers.v +++ b/test-suite/success/univers.v @@ -60,3 +60,20 @@ Qed. (* Submitted by Danko Ilik (bug report #1507); related to LetIn *) Record U : Type := { A:=Type; a:A }. + +(** Check assignement of sorts to inductives and records. *) + +Variable sh : list nat. + +Definition is_box_in_shape (b :nat * nat) := True. +Definition myType := Type. + +Module Ind. +Inductive box_in : myType := + myBox (coord : nat * nat) (_ : is_box_in_shape coord) : box_in. +End Ind. + +Module Rec. +Record box_in : myType := + BoxIn { coord :> nat * nat; _ : is_box_in_shape coord }. +End Rec. \ No newline at end of file -- cgit v1.2.3 From 4849c8eb1b7a386d2abcbc80c40de34b0a69b8ea Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Wed, 16 Mar 2016 18:18:54 +0100 Subject: Test file for #4624, fixed by Matthieu's bfce815bd1. --- test-suite/bugs/4624.v | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 test-suite/bugs/4624.v (limited to 'test-suite') diff --git a/test-suite/bugs/4624.v b/test-suite/bugs/4624.v new file mode 100644 index 0000000000..a737afcdab --- /dev/null +++ b/test-suite/bugs/4624.v @@ -0,0 +1,7 @@ +Record foo := mkfoo { type : Type }. + +Canonical Structure fooA (T : Type) := mkfoo (T -> T). + +Definition id (t : foo) (x : type t) := x. + +Definition bar := id _ ((fun x : nat => x) : _). \ No newline at end of file -- cgit v1.2.3 From bcee0b4d6ca113d225fa7df1cbcfa33812b0bd46 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Thu, 17 Mar 2016 18:06:50 +0100 Subject: Test file for #4623. --- test-suite/bugs/4623.v | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 test-suite/bugs/4623.v (limited to 'test-suite') diff --git a/test-suite/bugs/4623.v b/test-suite/bugs/4623.v new file mode 100644 index 0000000000..405d09809c --- /dev/null +++ b/test-suite/bugs/4623.v @@ -0,0 +1,5 @@ +Goal Type -> Type. +set (T := Type). +clearbody T. +refine (@id _). +Qed. \ No newline at end of file -- cgit v1.2.3 From c8dcfc691a649ff6dfb3416809c6ec7b1e629b1f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 17 Mar 2016 20:23:00 +0100 Subject: Fix bug #4627: records with no declared arity can be template polymorphic. As if we were adding : Type. Consistent with inductives with no declared arity. --- test-suite/bugs/closed/4627.v | 49 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) create mode 100644 test-suite/bugs/closed/4627.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4627.v b/test-suite/bugs/closed/4627.v new file mode 100644 index 0000000000..e1206bb37a --- /dev/null +++ b/test-suite/bugs/closed/4627.v @@ -0,0 +1,49 @@ +Class sa (A:Type) := { }. + +Record predicate A (sa:sa A) := + { pred_fun: A->Prop }. +Record ABC : Type := + { abc: Type }. +Record T := + { T_abc: ABC }. + + +(* +sa: forall _ : Type@{Top.179}, Prop +predicate: forall (A : Type@{Top.205}) (_ : sa A), Type@{max(Set+1, Top.205)} +T: Type@{Top.208+1} +ABC: Type@{Top.208+1} +abc: forall _ : ABC, Type@{Top.208} + +Top.205 <= Top.179 predicate <= sa.A +Set < Top.208 Set < abc +Set < Top.205 Set < predicate +*) + +Definition foo : predicate T (Build_sa T) := + {| pred_fun:= fun w => True |}. +(* *) +(* Top.208 < Top.205 <--- added by foo *) +(* *) + +Check predicate nat (Build_sa nat). +(* + +The issue is that the template polymorphic universe of [predicate], Top.205, does not get replaced with the universe of [nat] in the above line. + -Jason Gross + +8.5 -- predicate nat (Build_sa nat): Type@{max(Set+1, Top.205)} +8.5 EXPECTED -- predicate nat (Build_sa nat): Type@{Set+1} +8.4pl4 -- predicate nat {| |}: Type (* max(Set, (Set)+1) *) +*) + +(* This works in 8.4pl4 and SHOULD work in 8.5 *) +Definition bar : ABC := + {| abc:= predicate nat (Build_sa nat) |}. +(* +The term "predicate nat (Build_sa nat)" has type + "Type@{max(Set+1, Top.205)}" +while it is expected to have type "Type@{Top.208}" +(universe inconsistency: Cannot enforce Top.205 <= +Top.208 because Top.208 < Top.205). +*) \ No newline at end of file -- cgit v1.2.3 From 5c8fc9aebe072237a65fc9ed7acf8ae559a78243 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 16 Mar 2016 19:27:00 +0100 Subject: Moving the parsing of the Ltac proof mode to G_ltac. --- test-suite/bugs/opened/3410.v | 1 - test-suite/ide/undo013.fake | 2 +- test-suite/ide/undo014.fake | 2 +- test-suite/ide/undo015.fake | 2 +- test-suite/ide/undo016.fake | 2 +- 5 files changed, 4 insertions(+), 5 deletions(-) delete mode 100644 test-suite/bugs/opened/3410.v (limited to 'test-suite') diff --git a/test-suite/bugs/opened/3410.v b/test-suite/bugs/opened/3410.v deleted file mode 100644 index 0d259181aa..0000000000 --- a/test-suite/bugs/opened/3410.v +++ /dev/null @@ -1 +0,0 @@ -Fail repeat match goal with H:_ |- _ => setoid_rewrite X in H end. diff --git a/test-suite/ide/undo013.fake b/test-suite/ide/undo013.fake index f44156aa38..921a9d0f0d 100644 --- a/test-suite/ide/undo013.fake +++ b/test-suite/ide/undo013.fake @@ -23,5 +23,5 @@ ADD { Qed. } ADD { apply H. } # ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo014.fake b/test-suite/ide/undo014.fake index 6d58b061e6..f5fe774704 100644 --- a/test-suite/ide/undo014.fake +++ b/test-suite/ide/undo014.fake @@ -22,5 +22,5 @@ ADD { destruct H. } ADD { Qed. } ADD { apply H. } ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo015.fake b/test-suite/ide/undo015.fake index ac17985aab..a1e5c947b3 100644 --- a/test-suite/ide/undo015.fake +++ b/test-suite/ide/undo015.fake @@ -25,5 +25,5 @@ ADD { destruct H. } ADD { Qed. } ADD { apply H. } ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo016.fake b/test-suite/ide/undo016.fake index bdb81ecd95..f9414c1ea7 100644 --- a/test-suite/ide/undo016.fake +++ b/test-suite/ide/undo016.fake @@ -27,5 +27,5 @@ ADD { destruct H. } ADD { Qed. } ADD { apply H. } ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } -- cgit v1.2.3 From 3bdbbc287bc0138541db2bfabadd8196269c8f56 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 25 Mar 2016 13:09:18 +0100 Subject: Test suite file for a bug in int31 arithmetic fixed a while ago. --- test-suite/failure/int31.v | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 test-suite/failure/int31.v (limited to 'test-suite') diff --git a/test-suite/failure/int31.v b/test-suite/failure/int31.v new file mode 100644 index 0000000000..b1d112247f --- /dev/null +++ b/test-suite/failure/int31.v @@ -0,0 +1,17 @@ +Require Import Int31 BigN. + +Open Scope int31_scope. + +(* This used to go through because of an unbalanced stack bug in the bytecode +interpreter *) + +Lemma bad : False. +assert (1 = 2). +change 1 with (add31 (addmuldiv31 65 (add31 1 1) 2) 1). +Fail vm_compute; reflexivity. +(* +discriminate. +Qed. +*) +Abort. + -- cgit v1.2.3 From a54579dd20e04ea919f8fa887e15dd82051fa297 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 25 Mar 2016 13:17:23 +0100 Subject: Test suite file for a bug in BigQ arithmetic fixed a while ago. --- test-suite/success/bigQ.v | 66 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) create mode 100644 test-suite/success/bigQ.v (limited to 'test-suite') diff --git a/test-suite/success/bigQ.v b/test-suite/success/bigQ.v new file mode 100644 index 0000000000..7fd0cf669d --- /dev/null +++ b/test-suite/success/bigQ.v @@ -0,0 +1,66 @@ +Require Import BigQ. +Import List. + +Definition pi_4_approx_low' := +(5066193963420194617885108698600649932059391557720145469382602092416947640628637390992675949693715109726079394291478795603894419483819297806310615866892414925850691415582239745615128821983865262221858109336884967754871321668348027076234335167119885298878199925731495390387858629042311908406056230882123787019283378509712244687397013657159455607193734144010901984756727174636853404278421831024545476850410085042498464474261035780891759930905778986584183710930670670301831474144997069400304290351567959717683444430666444319233768399342338059169002790777424962570605618705584660815518973602995097110557181643034682308210782171804373210646804613922337450953858508244032293753591878060539465788294318856859293281629951093130167801471787011911886414492513677892193100809508943832528344473873460853362957387889412799458784754514139679847887887544849825173792522272708046699681079289358082661375778523609867456540595586031625044964543428047238934233579184772793670436643502740076366994465457847106782560289782615794595755672643440040123002018908935362541166831619056664637901929131328502017686713274283777724453661234225382109584471950444925886358166551424008707439387934109226545596919797083495958300914344992836193126080289565652575543234385558967555959267746932292860747199382633363026440008828134867747920263181610216905129926037611247017868033961426567047355301676870662406173724238530061264149506666345040372864118731705584795947926329181826992456072045382170981478151356381437136818835196834068650217794381425547036331194595892801393225038235274901050364737353586927051766717037643833477566087835266968086513005761986678747515870298138062157791066648217784877968385924845017637219384732843791052551854695220023477365706464590594542001161575677402761543188277502092362285265847964496740584911576627239093631932307473445797386335961743298553548881544486940399236133577915988716682746485564575640818803540680574730591500432326858763829791848612343662539095316357052823005419355719381626599487868023399182174939253393897549026675976384326749445831606130546375395770778462506203752920470130305293966478109733954117063941901686840180727195741528561335809865193566993349413786715403053579411364371500063193205131503024022217701373077790337150298315820556080596579100618643147698304927957576213733526923182742441048553793831725592624850721293495085399785588171300815789795594858916409701139277050529011775828846362873246196866089783324522718656445008090114701320562608474099248873638488023114015981013142490827777895317580810590743940417298263300561876701828404744082864248409230009391001735746615476377303707782123483770118391136826609366946585715225248587168403619476143657107412319421501162805102723455593551478028055839072686207007765300258935153546418515706362733656094770289090398825190320430416955807878686642673124733998295439657633866090085982598765253268688814792672416195730086607425842181518560588819896560847103627615434844684536463752986969865794019299978956052589825441828842338163389851892617560591840546654410705167593310272272965900821031821380595084783691324416454359888103920904935692840264474003367023256964191100139001239923263691779167792867186165635514824889759796850863175082506408142175595463676408992027105356481220754473245821534527625758942093801142305560662681150069082553674495761075895588095760081401141419460482860852822686860785424514171214889677926763812031823537071721974799922995763666175738785000806081164280471363125324839717808977470218218571800106898347366938927189989988149888641129263448064762730769285877330997355234347773807099829665997515649429224335217107760728789764718885665291038706425454675746218345291274054088843647602239258308472486102933167465443294268551209015027897159307743987020521392788721231001835675584104894174434637260464035122611721657641428625505184886116917149318963070896162119215386541876236027342810162765609201440423207771441367926085768438143507025739041041240810056881304230519058117534418374553879198061289605354335880794397478047346975609179199801003098836622253165101961484972165230151495472006888128587168049198312469715081555662345452800468933420359802645393289853553618279788400476187713990872203669487294118461245455333004125835663010526985716431187034663870796866708678078952110615910196519835267441831874676895301527286826106517027821074816850326548617513767142627360001181210946100011774672126943957522004190414960909074050454565964857276407084991922274068961845339154089866785707764290964299529444616711194034827611771558783466230353209661849406004241580029437779784290315347968833708422223285859451369907260780956405036020581705441364379616715041818815829810906212826084485200785283123265202151252852134381195424724503189247411069117189489985791487434549080447866370484866697404176437230771558469231403088139693477706784802801265075586678597768511791952562627345622499328 + # 100788726492580594349650258277496659410917619472657560321971265983799894639441017438166498752997098978003489632843381325240982516059309714013145358125224597827602157516585886911710102182473475545864474089191789296685473601331678556438310133356793199956062857423397512495293688453655805536015029176541424005214818033707522950635262669828538132795615008381824067071229426026518897202246241637377064076189277685257166926338187911595052586669184297526234794666364657344206795357967279911782849686515024121916258300642000317525374433525235296287037535618423661645124459323811792936193272341688261801253469089129439519903538495370298752436267926761998785090092411372633429302950606054074205533246665546979112178855223925266166034953000200646676762301817000435641690517142795144469005596172113586738287118865058604922865654348297975054956781513943444060257230946224520058527667925776273088622386666860662470481606622952298649177217986593047495967209669116410592230626047083795555559776477430548946990993890380787911273437967786556742804566652408275798339221179283430482118140020742719695900657696142739101628984271513292954605191778803974738871043737934546460016184719168074062912083778327025499841998124431899131874519812228674255796948879306477894924710085384116453080236862135706628989104070747737689294987000148388110561753028594988959655591699155508380909698460304884908709246116411180876105681720036833487450945730831039969246996849503525429840196651386469599438064049723005123629385485140945945416764414133189625489032807860400751723995946290581976152580477047961138617997133510128194027510895265424780627975864980749945631413855375897945293107842908479797077570371447220506451229526132919408351287454305932886749170523056147842439813407002950370505941417426433452282518739345666494683448699945734453214481915512562995906034771246088038719298959180199052759295868161570318718927430655393250250811804905393113074074574608255523847592006804881016594060188745212933427473833239777228852952217878690668413947367586040297784502192683200664398064682201012931468052982448022330449955215606614483165425935154496289535573901139223034819824408001205784146243892228030383941863746839845526558421740316887532141893650230936137269356278754487130882868595412163277284772124736531380334814212708066069618080153747333573454834500999083737284449542481264971030785043701582134343596645346132964567391370300568578875509971483039720438955919863275044932311289587494336123538202079503922025306586828117649623642521324286648529829664567232756108169459356549144779085080036654897525078792273443307070502103724611233768453196294899770515940520895908289018412144327894912660060761908970811602375085884115384049610753387776858733798341463052471017393165656926510611173543365663267563198760597092606598728110197523695339144204179424646442294307593146446562536865057987897899655645968129515654148044008249646703504419478535298270862753806142083172190778193001810574370442181909146645889199829207284871551220439225371051511970054965951914399901815408791418836185742573331879114400013259342896515702942707292473805188905427717363630137869116872433627556880809120353079342030725196065815470427569172350436988386579444534375353968759750750178342190349607711313840613843718547859929387259163285524671855725511880656411741012446023392964655239624520090988149679656514996202498334816938716757663800773997302639681907686195671083505910700098597156238624351157219093280177066146218516478636356056420098245995113668018177690728654922707281126889313941750547830163078886329630807850633273613622550216189245162735650139455042125252043274668279981753287687674520319519360593091620297805736177366738063651905396783336064579717230286821545930579779462534206093794040878198825916141099864730374109311705285661056855668930671948265232862757146615431791375559792290479316263924560826544387396762768331402198937951439504767950821089741987629257538953417586416459087855138539304027013800937360598578194413362672871055543854633921502486683911956250444582746421552178164852341035733290405311280719066037175324627429434912416361334254696649419037348733709488576582107382055914938194078813926926742828297826939120316120573453588052056773875836843924877773978390546387248009519202370375478981843515393806263037580338009594022254079586380520797699651840576286033587273591899639699077044271208886940540056794360292760863657703246410020854088849880453524038877935317875884698324859548991680533307680053872403383516589028793015681082435908524045497475001609824047204954932626536311826911363867426654549346914317405110707189532251727848751560224936842128628673253616256326013555922159336370177663785738170802777550686079119049748734352584409583136667752555307842739679930698964098088960000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%bigQ +. + +Definition pi_4_approx_high' := +(5066193963420194617885108698600649932059391557720145469382602092416947640628637390992675949693715109726079394291478795603894419483819297806310615866892414925850691415582239745615128821983865262221858109336884967754871321668348027076234335167119885298878199925731495390387858629042311908406056230882123787019283378509712244687397013657159455607193734144010901984756727174636853404278421831024545476850410085042498464474261035780891759930905778986584183710930670670301831474144997069400304290351567959717683444430666444319233768399342338059169002790777424962570605618705584660815518973602995097110557181643034682308210788409308322071457087096445676662503017187903223859814905546579050729173916234740628466315449085686468204847296426235788544874405450791749423436215032927889914519102361378633666267941326393265376660400091389373564825046526561381561278586121772300141564909333667988204680492088607706214346458601842899721615765319505314310192693665547163360402786722105590252780194994950097926184146718893770363322073641336811404180286358079915338791029818581497746089864894356686643882883410392601500048021013346713450539807687779704798018559373507951388092945938366448668853081682176581336156031434604604833692503597621519809826880683536141897075567053733515342478008373282599947520770191238802249392773327261328133194484586433840861730959791563023761306622956165536481335792721379318928171897265310054788931201902441066997927781894934061720760080768154565282051604447333036111267534150649674590201404453202347064545359869105856798745664471694795576801148562495225166002814304124970965817043547048503388910163287916513427409193998045119986267987892522931703487420953769290650229176116308194977201080691718825944370436642709192983358059711255925052564016519597530235976618244111239816418652282585432539731271068892992142956810775762851238126881225206289553948196520384709574383566733478326330112084307565420647201107231840508040019131253750047046446929758911912155202166566751947087545292626353331520202690130850009389387290465497377022080531269511355734944672010542204118978272180881335465227900174033380001851066811103401787656367819132934758616060307366679580043123632565656840669377840733018248707250548277181001911990237151790533341326223932843775840498222236867608395855700891719880219904948672458645420169533565809609056209006342663841718949396996175294237942265325043426430990062217643279654512512640557763489491751115437780462208361129433667449740743123546232162409802316714286708788831227582498585478334315076725145986771341647015244092760289407649044493584479944044779273447198382196766547779885914425854375158084417582279211000449529495605127376707776277159376010648950025135061284601443461110447113346277147728593420397807946636800365109579479211273476195727270004743568492888900356505584731622538401071221591141889158461271000051210318027818802379539544396973228585821742794928813630781709195703717312953337431290682263448669168179857644544116657440168099166467471736180072984407514757289757495435699300593165669101965987430482600019222913485092771346963058673132443387835726110205958057187517487684058179749952286341120230051432903482992282688283815697442898155194928723360957436110770317998431272108100149791425689283090777721270428030993332057319821685391144252815655146410678839177846108260765981523812232294638190350688210999605869296307711846463311346627138400477211801219366400312514793356564308532012682051019030257269068628100171220662165246389309014292764479226570049772046255291379151017129899157296574099437276707879597755725339406865738613810979022640265737120949077721294633786520294559343155148383011293584240192753971366644780434237846862975993387453786681995831719537733846579480995517357440575781962659282856696638992709756358478461648462532279323701121386551383509193782388241965285971965887701816406255233933761008649762854363984142178331798953040874526844255758512982810004271235810681505829473926495256537353108899526434200682024946218302499640511518360332022463196599199779172637638655415918976955930735312156870786600023896830267884391447789311101069654521354446521135407720085038662159974712373018912537116964809382149581004863115431780452188813210275393919111435118030412595133958954313836191108258769640843644195537185904547405641078708492098917460393911427237155683288565433183738513871595286090814836422982384810033331519971102974091067660369548406192526284519976668985518575216481570167748402860759832933071281814538397923687510782620605409323050353840034866296214149657376249634795555007199540807313397329050410326609108411299737760271566308288500400587417017113933243099961248847368789383209110747378488312550109911605079801570534271874115018095746872468910162721975463388518648962869080447866370484866697404176437230771558469231403088139693477706784802801265075586678597768511791952562627345622499328 + # 100788726492580594349650258277496659410917619472657560321971265983799894639441017438166498752997098978003489632843381325240982516059309714013145358125224597827602157516585886911710102182473475545864474089191789296685473601331678556438310133356793199956062857423397512495293688453655805536015029176541424005214818033707522950635262669828538132795615008381824067071229426026518897202246241637377064076189277685257166926338187911595052586669184297526234794666364657344206795357967279911782849686515024121916258300642000317525374433525235296287037535618423661645124459323811792936193272341688261801253469089129439519903538495370298752436267926761998785090092411372633429302950606054074205533246665546979112178855223925266166034953000200646676762301817000435641690517142795144469005596172113586738287118865058604922865654348297975054956781513943444060257230946224520058527667925776273088622386666860662470481606622952298649177217986593047495967209669116410592230626047083795555559776477430548946990993890380787911273437967786556742804566652408275798339221179283430482118140020742719695900657696142739101628984271513292954605191778803974738871043737934546460016184719168074062912083778327025499841998124431899131874519812228674255796948879306477894924710085384116453080236862135706628989104070747737689294987000148388110561753028594988959655591699155508380909698460304884908709246116411180876105681720036833487450945730831039969246996849503525429840196651386469599438064049723005123629385485140945945416764414133189625489032807860400751723995946290581976152580477047961138617997133510128194027510895265424780627975864980749945631413855375897945293107842908479797077570371447220506451229526132919408351287454305932886749170523056147842439813407002950370505941417426433452282518739345666494683448699945734453214481915512562995906034771246088038719298959180199052759295868161570318718927430655393250250811804905393113074074574608255523847592006804881016594060188745212933427473833239777228852952217878690668413947367586040297784502192683200664398064682201012931468052982448022330449955215606614483165425935154496289535573901139223034819824408001205784146243892228030383941863746839845526558421740316887532141893650230936137269356278754487130882868595412163277284772124736531380334814212708066069618080153747333573454834500999083737284449542481264971030785043701582134343596645346132964567391370300568578875509971483039720438955919863275044932311289587494336123538202079503922025306586828117649623642521324286648529829664567232756108169459356549144779085080036654897525078792273443307070502103724611233768453196294899770515940520895908289018412144327894912660060761908970811602375085884115384049610753387776858733798341463052471017393165656926510611173543365663267563198760597092606598728110197523695339144204179424646442294307593146446562536865057987897899655645968129515654148044008249646703504419478535298270862753806142083172190778193001810574370442181909146645889199829207284871551220439225371051511970054965951914399901815408791418836185742573331879114400013259342896515702942707292473805188905427717363630137869116872433627556880809120353079342030725196065815470427569172350436988386579444534375353968759750750178342190349607711313840613843718547859929387259163285524671855725511880656411741012446023392964655239624520090988149679656514996202498334816938716757663800773997302639681907686195671083505910700098597156238624351157219093280177066146218516478636356056420098245995113668018177690728654922707281126889313941750547830163078886329630807850633273613622550216189245162735650139455042125252043274668279981753287687674520319519360593091620297805736177366738063651905396783336064579717230286821545930579779462534206093794040878198825916141099864730374109311705285661056855668930671948265232862757146615431791375559792290479316263924560826544387396762768331402198937951439504767950821089741987629257538953417586416459087855138539304027013800937360598578194413362672871055543854633921502486683911956250444582746421552178164852341035733290405311280719066037175324627429434912416361334254696649419037348733709488576582107382055914938194078813926926742828297826939120316120573453588052056773875836843924877773978390546387248009519202370375478981843515393806263037580338009594022254079586380520797699651840576286033587273591899639699077044271208886940540056794360292760863657703246410020854088849880453524038877935317875884698324859548991680533307680053872403383516589028793015681082435908524045497475001609824047204954932626536311826911363867426654549346914317405110707189532251727848751560224936842128628673253616256326013555922159336370177663785738170802777550686079119049748734352584409583136667752555307842739679930698964098088960000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%bigQ +. + +Fixpoint numden_Rcontfrac_tailrecB (accu: list bigZ) (n1 d1: bigZ) (n2 d2: bigZ) (fuel: nat) {struct fuel}: + (list bigZ * bigQ * bigQ) := + let default := (rev_append accu nil, BigQ.div (BigQ.Qz n1) (BigQ.Qz d1), BigQ.div (BigQ.Qz n2) (BigQ.Qz d2)) in + match fuel with + | O => default + | S fuel' => + let '(q1, r1) := BigZ.div_eucl n1 d1 in + let '(q2, r2) := BigZ.div_eucl n2 d2 in + match BigZ.eqb q1 q2 with + | false => default + | true => + let r1_is_zero := BigZ.eqb r1 0 in + let r2_is_zero := BigZ.eqb r2 0 in + match Bool.eqb r1_is_zero r2_is_zero with + | false => default + | true => + match r1_is_zero with + | true => + match BigZ.eqb q1 1 with + | true => (rev_append accu nil, 1%bigQ, 1%bigQ) + | false => (rev_append ((q1 - 1)%bigZ :: accu) nil, 1%bigQ, 1%bigQ) + end + | false => numden_Rcontfrac_tailrecB (q1 :: accu) d1 r1 d2 r2 fuel' + end + end + end + end. + +Definition Bnum b := + match b with + | BigQ.Qz t => t + | BigQ.Qq n d => + if (d =? BigN.zero)%bigN then 0%bigZ else n + end. + +Definition Bden b := + match b with + | BigQ.Qz _ => 1%bigN + | BigQ.Qq _ d => if (d =? BigN.zero)%bigN then 1%bigN else d + end. + +Definition rat_Rcontfrac_tailrecB q1 q2 := + numden_Rcontfrac_tailrecB nil (Bnum q1) (BigZ.Pos (Bden q1)) (Bnum q2) (BigZ.Pos (Bden q2)). + +Definition pi_4_contfrac := + rat_Rcontfrac_tailrecB pi_4_approx_low' pi_4_approx_high' 3000. + +(* The following used to fail because of a non canonical representation of 0 in +the bytecode interpreter. Bug reported privately by Tahina Ramananandro. *) +Goal pi_4_contfrac = pi_4_contfrac. +vm_compute. +reflexivity. +Qed. -- cgit v1.2.3 From d670c6b6ceab80f1c3b6b74ffb53579670c0e621 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Mon, 28 Mar 2016 17:53:43 +0200 Subject: Fixing an incorrect use of prod_appvect on a term which was not a product in setoid_rewrite. Before commit e8c47b652, it was raising an error which has been turned to an anomaly. This impacted Compcert where the former error was (apparently) caught so that setoid_rewrite was returning back to ordinary rewrite. --- test-suite/success/setoid_test.v | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'test-suite') diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index 0465c4b3fb..4c173a3cd5 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -166,3 +166,11 @@ Proof. intros. setoid_rewrite <- foo_prf. change (beq_nat x 0 = y). Abort. Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y. Proof. intros. setoid_rewrite <- @foo_prf at 1. change (beq_nat x 0 = foo_neg y). Abort. +(* This should not raise an anomaly as it did for some time in early 2016 *) + +Definition t := nat -> bool. +Definition h (a b : t) := forall n, a n = b n. +Goal forall a b, h a b -> a 0 = true. +intros. +rewrite H. (* Fallback on ordinary rewrite without anomaly *) +Abort. -- cgit v1.2.3 From bacba3d3ec0dd54d210bdf5045bc7e193c904b3c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 31 Mar 2016 19:37:40 +0200 Subject: Adding a test for bug #1850. --- test-suite/bugs/closed/1850.v | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 test-suite/bugs/closed/1850.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/1850.v b/test-suite/bugs/closed/1850.v new file mode 100644 index 0000000000..26b48093b7 --- /dev/null +++ b/test-suite/bugs/closed/1850.v @@ -0,0 +1,4 @@ +Parameter P : Type -> Type -> Type. +Notation "e |= t --> v" := (P e t v) (at level 100, t at level 54). +Fail Check (nat |= nat --> nat). + -- cgit v1.2.3 From a585d46fbacfcc9cddf3da439e5f7001d429ba2a Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Tue, 5 Apr 2016 12:56:52 -0400 Subject: Fix bug #4656 I introduced this bug in 4c078b0362542908eb2fe1d63f0d867b339953fd; Coq.Init.Notations.constructor does not take any arguments. --- test-suite/bugs/closed/4656.v | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 test-suite/bugs/closed/4656.v (limited to 'test-suite') diff --git a/test-suite/bugs/closed/4656.v b/test-suite/bugs/closed/4656.v new file mode 100644 index 0000000000..c89a86d634 --- /dev/null +++ b/test-suite/bugs/closed/4656.v @@ -0,0 +1,4 @@ +(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *) +Goal True. + constructor 1. +Qed. -- cgit v1.2.3 From ab08345ebdb477bf4c83b46e0d8adc29296392f9 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Tue, 5 Apr 2016 13:18:00 -0400 Subject: Add -compat 8.4 econstructor tactics, and tests Passing `-compat 8.4` now allows the use of `econstructor (tac)`, as in 8.4. --- test-suite/success/Compat84.v | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 test-suite/success/Compat84.v (limited to 'test-suite') diff --git a/test-suite/success/Compat84.v b/test-suite/success/Compat84.v new file mode 100644 index 0000000000..db6348fa17 --- /dev/null +++ b/test-suite/success/Compat84.v @@ -0,0 +1,19 @@ +(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *) + +Goal True. + solve [ constructor 1 ]. Undo. + solve [ econstructor 1 ]. Undo. + solve [ constructor ]. Undo. + solve [ econstructor ]. Undo. + solve [ constructor (fail) ]. Undo. + solve [ econstructor (fail) ]. Undo. + split. +Qed. + +Goal False \/ True. + solve [ constructor (constructor) ]. Undo. + solve [ econstructor (econstructor) ]. Undo. + solve [ constructor 2; constructor ]. Undo. + solve [ econstructor 2; econstructor ]. Undo. + right; esplit. +Qed. -- cgit v1.2.3 From 9d50e5426cc816789650b7f541793a9ba773d14c Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Thu, 7 Apr 2016 14:14:33 +0200 Subject: An example which failed in 8.5 and that d670c6b6 fixes. Thanks to Matthieu for the example. --- test-suite/success/setoid_test.v | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'test-suite') diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index 4c173a3cd5..1f24ef2a6b 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -170,7 +170,12 @@ Proof. intros. setoid_rewrite <- @foo_prf at 1. change (beq_nat x 0 = foo_neg y) Definition t := nat -> bool. Definition h (a b : t) := forall n, a n = b n. -Goal forall a b, h a b -> a 0 = true. + +Instance subrelh : subrelation h (Morphisms.pointwise_relation nat eq). +Proof. intros x y H; assumption. Qed. + +Goal forall a b, h a b -> a 0 = b 0. intros. -rewrite H. (* Fallback on ordinary rewrite without anomaly *) -Abort. +setoid_rewrite H. (* Fallback on ordinary rewrite without anomaly *) +reflexivity. +Qed. -- cgit v1.2.3 From 9f0a896536e709880de5ba638069dea680803f62 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 7 Apr 2016 15:50:26 +0200 Subject: Allow to unset the refinement mode of Instance in ML Falling back to the global setting if not given. Useful to make Add Morphism fail correctly when the given proof terms are incomplete. Adapt test-suite file #2848 accordingly. --- test-suite/bugs/closed/2848.v | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'test-suite') diff --git a/test-suite/bugs/closed/2848.v b/test-suite/bugs/closed/2848.v index de137d39d1..828e3b8c1f 100644 --- a/test-suite/bugs/closed/2848.v +++ b/test-suite/bugs/closed/2848.v @@ -2,8 +2,9 @@ Require Import Setoid. Parameter value' : Type. Parameter equiv' : value' -> value' -> Prop. - +Axiom cheat : forall {A}, A. Add Parametric Relation : _ equiv' - reflexivity proved by (Equivalence.equiv_reflexive _) - transitivity proved by (Equivalence.equiv_transitive _) + reflexivity proved by (Equivalence.equiv_reflexive cheat) + transitivity proved by (Equivalence.equiv_transitive cheat) as apply_equiv'_rel. +Check apply_equiv'_rel : PreOrder equiv'. \ No newline at end of file -- cgit v1.2.3 From 1f6a31d138bcfcf341f28772de7c5e08906167c5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 8 Apr 2016 00:19:49 +0200 Subject: Fixing printing of Tactic Notations with tactic arguments. --- test-suite/success/TacticNotation2.v | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 test-suite/success/TacticNotation2.v (limited to 'test-suite') diff --git a/test-suite/success/TacticNotation2.v b/test-suite/success/TacticNotation2.v new file mode 100644 index 0000000000..cb341b8e10 --- /dev/null +++ b/test-suite/success/TacticNotation2.v @@ -0,0 +1,12 @@ +Tactic Notation "complete" tactic(tac) := tac; fail. + +Ltac f0 := complete (intuition idtac). +(** FIXME: This is badly printed because of bug #3079. + At least we check that it does not fail anomalously. *) +Print Ltac f0. + +Ltac f1 := complete f1. +Print Ltac f1. + +Ltac f2 := complete intuition. +Print Ltac f2. -- cgit v1.2.3 From f8f2c684ce97745350f8cbcb654a2ee27fb9d572 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Sat, 9 Apr 2016 18:18:46 +0200 Subject: A small test of Print Ltac. --- test-suite/output/ltac.out | 3 +++ test-suite/output/ltac.v | 10 ++++++++++ 2 files changed, 13 insertions(+) (limited to 'test-suite') diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index d003c70df9..20e274e254 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -1,2 +1,5 @@ The command has indeed failed with message: Error: Ltac variable y depends on pattern variable name z which is not bound in current context. +Ltac f x y z := + symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize + dependent z diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 7e2610c7d7..373b870b9f 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -15,3 +15,13 @@ lazymatch goal with | H1 : HT |- _ => idtac end. Abort. + +Ltac f x y z := + symmetry in x, y; + auto with z; + auto; + intros; + clearbody x; + generalize dependent z. + +Print Ltac f. -- cgit v1.2.3