diff options
Diffstat (limited to 'test-suite/bugs/opened')
70 files changed, 2434 insertions, 54 deletions
diff --git a/test-suite/bugs/opened/shouldnotfail/1338.v-disabled b/test-suite/bugs/opened/1338.v-disabled index f383d534..ab0f9820 100644 --- a/test-suite/bugs/opened/shouldnotfail/1338.v-disabled +++ b/test-suite/bugs/opened/1338.v-disabled @@ -8,5 +8,5 @@ x <> 0 -> x <> 18 -> x <> 19 -> x <> 20 -> False. Proof. intros. - omega. -Qed. + Fail omega. +Abort. diff --git a/test-suite/bugs/opened/shouldnotfail/1501.v b/test-suite/bugs/opened/1501.v index 1845dd1f..b36f21da 100644 --- a/test-suite/bugs/opened/shouldnotfail/1501.v +++ b/test-suite/bugs/opened/1501.v @@ -40,11 +40,13 @@ Parameter Hint Resolve equiv_refl equiv_sym equiv_trans: monad. -Add Relation K equiv - reflexivity proved by (@equiv_refl) - symmetry proved by (@equiv_sym) - transitivity proved by (@equiv_trans) - as equiv_rel. +Instance equiv_rel A: Equivalence (@equiv A). +Proof. + constructor. + intros xa; apply equiv_refl. + intros xa xb; apply equiv_sym. + intros xa xb xc; apply equiv_trans. +Defined. Definition fequiv (A B: Type) (f g: A -> K B) := forall (x:A), (equiv (f x) (g x)). @@ -67,17 +69,17 @@ Proof. unfold fequiv; intros; eapply equiv_trans; auto with monad. Qed. -Add Relation (fun (A B:Type) => A -> K B) fequiv - reflexivity proved by (@fequiv_refl) - symmetry proved by (@fequiv_sym) - transitivity proved by (@fequiv_trans) - as fequiv_rel. +Instance fequiv_re A B: Equivalence (@fequiv A B). +Proof. + constructor. + intros f; apply fequiv_refl. + intros f g; apply fequiv_sym. + intros f g h; apply fequiv_trans. +Defined. -Add Morphism bind - with signature equiv ==> fequiv ==> equiv - as bind_mor. +Instance bind_mor A B: Morphisms.Proper (@equiv _ ==> @fequiv _ _ ==> @equiv _) (@bind A B). Proof. - unfold fequiv; intros; apply bind_compat; auto. + unfold fequiv; intros x y xy_equiv f g fg_equiv; apply bind_compat; auto. Qed. Lemma test: @@ -88,6 +90,7 @@ Lemma test: Proof. intros A B m1 m2 m3 f H1 H2. setoid_rewrite H1. (* this works *) - setoid_rewrite H2. - trivial by equiv_refl. -Qed. + Fail setoid_rewrite H2. +Abort. +(* trivial by equiv_refl. +Qed.*) diff --git a/test-suite/bugs/opened/shouldnotfail/1596.v b/test-suite/bugs/opened/1596.v index de77e35d..7c5dc416 100644 --- a/test-suite/bugs/opened/shouldnotfail/1596.v +++ b/test-suite/bugs/opened/1596.v @@ -1,7 +1,10 @@ - Require Import Relations. Require Import FSets. Require Import Arith. +Require Import Omega. +Unset Standard Proposition Elimination Names. + +Set Keyed Unification. Lemma Bool_elim_bool : forall (b:bool),b=true \/ b=false. destruct b;try tauto. @@ -100,6 +103,16 @@ Definition t := (X.t * Y.t)%type. left;trivial. Defined. + Definition eq_dec : forall (x y: t), { eq x y } + { ~ eq x y}. + Proof. + intros [xa xb] [ya yb]; simpl. + destruct (X.eq_dec xa ya). + destruct (Y.eq_dec xb yb). + + left; now split. + + right. now intros [eqa eqb]. + + right. now intros [eqa eqb]. + Defined. + Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. End OrderedPair. @@ -158,6 +171,14 @@ GT;simpl;trivial;fail). apply GT;trivial. Defined. + Definition eq_dec : forall (x y: t), { eq x y } + { ~ eq x y}. + Proof. + intros [i] [j]. unfold eq. + destruct (eq_nat_dec i j). + + left. now f_equal. + + right. intros meq; now inversion meq. + Defined. + Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. End Ord. @@ -235,8 +256,6 @@ n). induction m;simpl;intro. elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros. apply SynInc;apply H.mem_2;trivial. - - rewrite H in H0. (* !! impossible here !! *) - discriminate H0. + rewrite H in H0. discriminate. (* !! impossible here !! *) Qed. End B.
\ No newline at end of file diff --git a/test-suite/bugs/opened/shouldnotfail/1671.v b/test-suite/bugs/opened/1671.v index d95c2108..b4e653f6 100644 --- a/test-suite/bugs/opened/shouldnotfail/1671.v +++ b/test-suite/bugs/opened/1671.v @@ -6,7 +6,7 @@ CoInductive hdlist : unit -> Type := Variable P : forall bo, hdlist bo -> Prop. Variable all : forall bo l, P bo l. -Definition F (l:hdlist tt) : P tt l := +Fail Definition F (l:hdlist tt) : P tt l := match l in hdlist u return P u l with | cons (cons l') => all tt _ end. diff --git a/test-suite/bugs/opened/1773.v b/test-suite/bugs/opened/1773.v deleted file mode 100644 index 4aabf19c..00000000 --- a/test-suite/bugs/opened/1773.v +++ /dev/null @@ -1,10 +0,0 @@ -Goal forall B C : nat -> nat -> Prop, forall k, C 0 k -> - (exists A, (forall k', C A k' -> B A k') -> B A k). -Proof. - intros B C k H. - econstructor. - intros X. - apply X. - apply H. -Qed. - diff --git a/test-suite/bugs/opened/shouldnotfail/1811.v b/test-suite/bugs/opened/1811.v index 037b7cb2..10c988fc 100644 --- a/test-suite/bugs/opened/shouldnotfail/1811.v +++ b/test-suite/bugs/opened/1811.v @@ -6,4 +6,5 @@ Proof. auto. Qed. Goal forall b1 b2, (negb b1 = b2) -> xorb true b1 = b2. Proof. intros b1 b2. - rewrite neg2xor.
\ No newline at end of file + Fail rewrite neg2xor. +Abort.
\ No newline at end of file diff --git a/test-suite/bugs/opened/2572.v-disabled b/test-suite/bugs/opened/2572.v-disabled new file mode 100644 index 00000000..3f6c6a0d --- /dev/null +++ b/test-suite/bugs/opened/2572.v-disabled @@ -0,0 +1,187 @@ +Require Import List. +Definition is_dec (P:Prop) := {P}+{~P}. +Definition eq_dec (T:Type) := forall (t1 t2:T), is_dec (t1=t2). + +Record Label : Type := mkLabel { + LabElem: Type; + LabProd: LabElem -> LabElem -> option LabElem; + LabBot: LabElem -> Prop; + LabError: LabElem -> Prop +}. + +Definition LProd (L1 L2: Label): Label := {| + LabElem := LabElem L1 * LabElem L2; + LabProd := fun lg ld => let (lg1,lg2) := lg in let (ld1,ld2) := ld in + match LabProd L1 lg1 ld1, LabProd L2 lg2 ld2 with + Some g, Some d => Some (g,d) + | _,_ => None + end; + LabBot l := let (l1,l2) := l in LabBot L1 l1 \/ LabBot L2 l2; + LabError l := let (l1,l2) := l in LabError L1 l1 \/ LabError L2 l2 +|}. + +Definition Lrestrict (L: Label) (S: LabElem L -> bool): Label := {| + LabElem := LabElem L; + LabProd l1 l2 := if andb (S l1) (S l2) then LabProd L l1 l2 else None; + LabBot l := LabBot L l; + LabError l := LabError L l +|}. + +Notation "l1 ^* l2" := (LProd l1 l2) (at level 50). + +Record LTS(L:Type): Type := mkLTS { + State: Type; + Init: State -> Prop; + Next: State -> L -> State -> Prop +}. +Implicit Arguments State. +Implicit Arguments Init. +Implicit Arguments Next. + +Definition sound L (S: LTS (LabElem L)): Prop := + forall s s' l, Next S s l s' -> ~LabError L l. + +Inductive PNext L (S1 S2:LTS (LabElem L)): State S1 * State S2 -> (LabElem L) -> State S1 * State S2 -> Prop := + LNext: forall s1 s2 l1 s'1, Next S1 s1 l1 s'1 -> (forall l2, LabProd L l1 l2 = None) -> + PNext L S1 S2 (s1,s2) l1 (s'1,s2) +| RNext: forall s1 s2 l2 s'2, (forall l1, LabProd L l1 l2 = None) -> Next S2 s2 l2 s'2 -> + PNext L S1 S2 (s1,s2) l2 (s1,s'2) +| SNext: forall s1 s2 l1 l2 l s'1 s'2, Next S1 s1 l1 s'1 -> Next S2 s2 l2 s'2 -> + Some l = LabProd L l1 l2 -> PNext L S1 S2 (s1,s2) l (s'1,s'2). + +Definition Produit (L:Label) (S1 S2: LTS (LabElem L)): LTS (LabElem L) := {| + State := State S1 * State S2; + Init := fun s => let (s1,s2) := s in Init S1 s1 /\ Init S2 s2; + Next :=PNext L S1 S2 +|}. + +Parameter Time: Type. +Parameter teq: forall t1 t2:Time, {t1=t2}+{t1<>t2}. + +Inductive TLabElem(L:Type): Type := + Tdiscrete: L -> TLabElem L +| Tdelay: Time -> TLabElem L +| Tbot: TLabElem L. + +Definition TLabel L: Label := {| + LabElem := TLabElem (LabElem L); + LabProd lt1 lt2 := + match lt1, lt2 with + Tdiscrete l1, Tdiscrete l2 => match (LabProd L l1 l2) with Some l => Some (Tdiscrete (LabElem L) l) | None => None end + | Tdelay t1, Tdelay t2 => if teq t1 t2 then Some (Tdelay (LabElem L) t1) else Some (Tbot (LabElem L)) + | _,_ => None + end; + LabBot lt := match lt with + Tdiscrete l => LabBot L l + | Tbot => True + | _ => False + end; + LabError lt := match lt with + Tdiscrete l => LabError L l + | _ => False + end + |}. + +Parameter Var: Type. +Parameter allv: forall P, (forall (v:Var), is_dec (P v)) -> is_dec (forall v, P v). +Parameter DType: Type. +Parameter Data: DType -> Type. +Parameter vtype: Var -> DType. +Parameter Deq: forall t (d1 d2: Data t), is_dec (d1=d2). + +Inductive Vctr(v:Var): Type := + Wctr: Data (vtype v) -> Vctr v +| Rctr: Data (vtype v) -> Vctr v +| Fctr: Vctr v +| Nctr: Vctr v. + +Definition isCmp v (c1 c2: Vctr v): Prop := + match c1,c2 with + Wctr _, Nctr => True + | Rctr _, Rctr _ => True + | Rctr _, Nctr => True + | Rctr _, Fctr => True + | Nctr, _ => True + | _,_ => False + end. + +Lemma isCmp_dec: forall v (c1 c2: Vctr v), is_dec (isCmp v c1 c2). +intros. +induction c1; induction c2; simpl; intros; try (left; tauto); try (right; tauto). +Qed. + +Definition Vprod v (c1 c2: Vctr v): (isCmp v c1 c2) -> Vctr v := + match c1,c2 return isCmp v c1 c2 -> Vctr v with + | Wctr d, Nctr => fun h => Wctr v d + | Rctr d1, Rctr d2 => fun h => if Deq (vtype v) d1 d2 then Rctr v d1 else Fctr v + | Rctr d1, Nctr => fun h => Rctr v d1 + | Rctr d1, Fctr => fun h => Fctr v + | Fctr, Rctr _ => fun h => Fctr v + | Fctr, Fctr => fun h => Fctr v + | Fctr, Nctr => fun h => Fctr v + | Nctr, c2 => fun h => c2 + | _,_ => fun h => match h with end + end. + +Inductive MLabElem: Type := + Mctr: (forall v, Vctr v) -> MLabElem +| Merr: MLabElem. + +Definition MProd (m1 m2: MLabElem): MLabElem := + match m1,m2 with + Mctr c1, Mctr c2 => match allv (fun v => isCmp v (c1 v) (c2 v)) (fun v => isCmp_dec v (c1 v) (c2 v)) with + left h => Mctr (fun v => Vprod v (c1 v) (c2 v) (h v)) + | _ => Merr + end + | _,_ => Merr + end. + +Definition MLabel: Label := {| + LabElem := MLabElem; + LabProd m1 m2 := Some (MProd m1 m2); + LabBot m := exists c, m = Mctr c /\ exists v, c v = Fctr v; + LabError m := m = Merr +|}. + +Parameter Chan: Type. +Parameter ch_eq: eq_dec Chan. + +Definition CLabel(S: Chan->bool): Label := {| + LabElem := Chan; + LabProd := fun c1 c2 => if ch_eq c1 c2 then if S c1 then Some c1 else None else None; + LabBot := fun _ => False; + LabError := fun _ => False +|}. + +Definition FLabel(S: Chan->bool): Label := + TLabel (CLabel S ^* MLabel ^* MLabel ^* MLabel). + +Definition FTS := LTS (LabElem (FLabel (fun _ => true))). +Check (fun S (T1 T2: FTS) => Produit (FLabel S) T1 T2). +(* +Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS. +unfold FTS in *; simpl in *. +apply (Produit (FLabel S)). +apply T1. +apply T2. +Defined. + +Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS := + Produit (FLabel S) T1 T2. +*) +Lemma FTSirrel (S: Chan -> bool): FTS = LTS (LabElem (FLabel S)). +Proof. + unfold FTS. + simpl. + reflexivity. +Qed. + +Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS. +revert T2; revert T1. +rewrite (FTSirrel S). +apply (Produit (FLabel S)). +Defined. + +Record HTTS: Type := mkHTTS { + +}. diff --git a/test-suite/bugs/opened/2652a.v-disabled b/test-suite/bugs/opened/2652a.v-disabled new file mode 100644 index 00000000..0274037b --- /dev/null +++ b/test-suite/bugs/opened/2652a.v-disabled @@ -0,0 +1,106 @@ +Require Import Strings.String. +Require Import Classes.EquivDec. +Require Import Lists.List. + +Inductive Owner : Type := + | server : Owner + | client : Owner. + +Inductive ClassName : Type := + | className : string -> ClassName. + +Inductive Label : Type := + | label : nat -> Owner -> Label. + +Inductive Var : Type := + | var : string -> Var. + +Inductive FieldName : Type := + | fieldName : string -> Owner -> FieldName. + +Inductive MethodCall : Type := + | methodCall : string -> MethodCall. + +Inductive Exp : Type := + | varExp : Var -> Exp + | fieldReference : Var -> FieldName -> Exp + | methodCallExp : Var -> MethodCall -> list Var -> Exp + | allocation : ClassName -> list Var -> Exp + | cast : ClassName -> Var -> Exp. + +Inductive Stmt : Type := + | assignment : Var -> Exp -> Label -> Stmt + | returnStmt : Var -> Label -> Stmt + | fieldUpdate : Var -> FieldName -> Exp -> Label -> Stmt. + +Inductive Konst : Type := + | konst : ClassName -> (list (ClassName * FieldName)) -> list FieldName -> (list FieldName * FieldName) -> Konst. + +Inductive Method : Type := + | method : ClassName -> MethodCall -> list (ClassName * Var) -> list (ClassName * Var) -> (list Stmt) -> Method. + +Inductive Class : Type := + | class : ClassName -> ClassName -> (list (ClassName * FieldName)) -> (Konst * (list Method)) -> Class. + +Inductive Context : Type := + | context : nat -> Context. + +Inductive HContext : Type := + | heapContext : nat -> HContext. + +Inductive Location := loc : nat -> Location. + +Definition AbsLocation := ((Var * Context) + (FieldName * HContext)) % type. + +Definition CallStack := list (Stmt * Context * Var) % type. + +Inductive TypeState : Type := + | fresh : TypeState + | stale : TypeState. + +Definition Obj := (HContext * (FieldName -> option AbsLocation) * TypeState) % type. + +Definition Store := Location -> option Obj. + +Definition OwnerStore := Owner -> Store. + +Definition AbsStore := AbsLocation -> option (list Obj). + +Definition Stack := list (Var -> option Location). + +Definition Batch := list Location. + +Definition Sigma := (Stmt * Stack * OwnerStore * AbsStore * CallStack * Context * Batch) % type. + +Definition update {A : Type} {B : Type} `{EqDec A} `{EqDec B} (f : A -> B) (k : A) (v : B) : (A -> B) := + fun k' => if equiv_decb k' k then v else f k'. + + +Definition transfer : Label -> OwnerStore -> Batch -> (OwnerStore * Batch) := + fun _ o b => (o,b). + +Parameter succ : Label -> Stmt. + +Parameter owner : Label -> Owner. + +Inductive concreteSingleStep : Sigma -> Sigma -> Prop := + | fieldAssignmentLocal : forall v f_do f o so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b', + (f_do = fieldName f o) -> so = owner(l) -> sigma_so = sigma(so) -> Some (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (Some (hc, update m f_do st(v'), fresh)) + -> sigma' = update sigma so sigma'_so -> o = so -> (sigma'', b') = transfer l sigma' b -> + concreteSingleStep ((fieldUpdate v f_do (varExp v') l), st, sigma, absSigma, cst, c, b) + (succ(l), st, sigma'', absSigma, cst, c, b'). + + | fieldAssignmentRemote : forall v f_do f o so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b', + (f_do = fieldName f o) -> so = owner(l) -> sigma_so = sigma(so) -> (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (hc, update m f_do st(v'), fresh) + -> sigma' = update sigma so sigma'_so -> o <> so -> (sigma'', b') = transfer l sigma' (b ++ st(v)) -> + concreteSingleStep ((fieldUpdate v f_o (varExp v') l), st, sigma, absSigma, cst, c, b) + (succ(l), st, sigma'', absSigma, cst, c, b'') + | variableStep : forall v v' l st st' sigma sigma' absSigma cst c b b', + (st' = st ++ (update (fun _ => None) v st(v'))) -> (sigma',b') = transfer l sigma b -> + concreteSingleStep ((assignment v (varExp v') l), st, sigma, absSigma, cst, c, b) (succ(l), st', sigma', absSigma, cst, c, b') + | returnStep : forall v l st sigma absSigma cst c b v_ret s st' sigma' c' b', + (s,c',v_ret) = car(cst) -> st' = cdr(st) ++ update (fun _ => None) v_ret st(v) -> (sigma', b') = transfer l sigma b -> + concreteSingleStep ((returnStmt v l), st, sigma, absSigma, cst, c, b) (s, st', sigma', absSigma, cdr(cst), c', b') + | fieldReferenceStep : forall v v' f_do l st sigma absSigma cst c b so hc m' m st' sigma' absSigma cst c b', + so = owner(l) -> (hc, m', fresh) = sigma(so)(st(v')) -> m' = update m f_do l -> st' = st ++ update (fun _ => None) v l -> (sigma', b') = transfer l sigma b -> + concreteSingleStep ((assignment v (fieldReference v' f_do) l), st, sigma, absSigma, cst, c, b) (s, st', sigma', absSigma, cst, c, b'). diff --git a/test-suite/bugs/opened/2652b.v-disabled b/test-suite/bugs/opened/2652b.v-disabled new file mode 100644 index 00000000..b340436d --- /dev/null +++ b/test-suite/bugs/opened/2652b.v-disabled @@ -0,0 +1,88 @@ +(* This used to show a bug in evarutil. which is fixed in 8.4 *) +Require Import Strings.String. +Require Import Classes.EquivDec. +Require Import Lists.List. + +Inductive Owner : Type := + | server : Owner + | client : Owner. + +Inductive ClassName : Type := + | className : string -> ClassName. + +Inductive Label : Type := + | label : nat -> Owner -> Label. + +Inductive Var : Type := + | var : string -> Var. + +Inductive FieldName : Type := + | fieldName : string -> Owner -> FieldName. + +Inductive MethodCall : Type := + | methodCall : string -> MethodCall. + +Inductive Exp : Type := + | varExp : Var -> Exp + | fieldReference : Var -> FieldName -> Exp + | methodCallExp : Var -> MethodCall -> list Var -> Exp + | allocation : ClassName -> list Var -> Exp + | cast : ClassName -> Var -> Exp. + +Inductive Stmt : Type := + | assignment : Var -> Exp -> Label -> Stmt + | returnStmt : Var -> Label -> Stmt + | fieldUpdate : Var -> FieldName -> Exp -> Label -> Stmt. + +Inductive Konst : Type := + | konst : ClassName -> (list (ClassName * FieldName)) -> list FieldName -> (list FieldName * FieldName) -> Konst. + +Inductive Method : Type := + | method : ClassName -> MethodCall -> list (ClassName * Var) -> list (ClassName * Var) -> (list Stmt) -> Method. + +Inductive Class : Type := + | class : ClassName -> ClassName -> (list (ClassName * FieldName)) -> (Konst * (list Method)) -> Class. + +Inductive Context : Type := + | context : nat -> Context. + +Inductive HContext : Type := + | heapContext : nat -> HContext. + +Inductive Location := loc : nat -> Location. + +Definition AbsLocation := ((Var * Context) + (FieldName * HContext)) % type. + +Definition CallStack := list (Stmt * Context * Var) % type. + +Inductive TypeState : Type := + | fresh : TypeState + | stale : TypeState. + +Definition Obj := (HContext * (FieldName -> option AbsLocation) * TypeState) % type. + +Definition Store := Location -> option Obj. + +Definition OwnerStore := Owner -> Store. + +Definition AbsStore := AbsLocation -> option (list Obj). + +Definition Stack := list (Var -> option Location). + +Definition Batch := list Location. + +Definition Sigma := (Stmt * Stack * OwnerStore * AbsStore * CallStack * Context * Batch) % type. + +Definition update {A : Type} {B : Type} `{EqDec A} `{EqDec B} (f : A -> B) (k : A) (v : B) : (A -> B) := + fun k' => if equiv_decb k' k then v else f k'. + +Parameter succ : Label -> Stmt. + +Inductive concreteSingleStep : Sigma -> Sigma -> Prop := + | fieldAssignmentLocal : forall v f_do f o so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b', + Some (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (Some (hc, update m f_do st(v'), fresh)) + -> + concreteSingleStep ((fieldUpdate v f_do (varExp v') l), st, sigma, absSigma, cst, c, b) + (succ(l), st, sigma'', absSigma, cst, c, b'). + +. diff --git a/test-suite/bugs/opened/2800.v b/test-suite/bugs/opened/2800.v new file mode 100644 index 00000000..c559ab0c --- /dev/null +++ b/test-suite/bugs/opened/2800.v @@ -0,0 +1,6 @@ +Goal False. + +Fail intuition + match goal with + | |- _ => idtac " foo" + end. diff --git a/test-suite/bugs/opened/2814.v b/test-suite/bugs/opened/2814.v new file mode 100644 index 00000000..a740b438 --- /dev/null +++ b/test-suite/bugs/opened/2814.v @@ -0,0 +1,5 @@ +Require Import Program. + +Goal forall (x : Type) (f g : Type -> Type) (H : f x ~= g x), False. + intros. + Fail induction H. diff --git a/test-suite/bugs/opened/2951.v b/test-suite/bugs/opened/2951.v new file mode 100644 index 00000000..3739247b --- /dev/null +++ b/test-suite/bugs/opened/2951.v @@ -0,0 +1 @@ +Class C (A: Type) : Type := { f: A }. diff --git a/test-suite/bugs/opened/3010.v-disabled b/test-suite/bugs/opened/3010.v-disabled new file mode 100644 index 00000000..f2906bd6 --- /dev/null +++ b/test-suite/bugs/opened/3010.v-disabled @@ -0,0 +1 @@ +Definition em {A R} (k : forall s : sum A _, match s with inl x => R x | inr y => R end) := k (inr (fun x => k (inl x))).
\ No newline at end of file diff --git a/test-suite/bugs/opened/3045.v b/test-suite/bugs/opened/3045.v new file mode 100644 index 00000000..b7f40b4a --- /dev/null +++ b/test-suite/bugs/opened/3045.v @@ -0,0 +1,30 @@ +Set Asymmetric Patterns. +Generalizable All Variables. +Set Implicit Arguments. +Set Universe Polymorphism. + +Record SpecializedCategory (obj : Type) := + { + Object :> _ := obj; + Morphism : obj -> obj -> Type; + + Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' + }. + +Arguments Compose {obj} [C s d d'] m1 m2 : rename. + +Inductive ReifiedMorphism : forall objC (C : SpecializedCategory objC), C -> C -> Type := +| ReifiedComposedMorphism : forall objC C s d d', ReifiedMorphism C d d' -> ReifiedMorphism C s d -> @ReifiedMorphism objC C s d'. + +Fixpoint ReifiedMorphismDenote objC C s d (m : @ReifiedMorphism objC C s d) : Morphism C s d := + match m in @ReifiedMorphism objC C s d return Morphism C s d with + | ReifiedComposedMorphism _ _ _ _ _ m1 m2 => Compose (@ReifiedMorphismDenote _ _ _ _ m1) + (@ReifiedMorphismDenote _ _ _ _ m2) + end. + +Fixpoint ReifiedMorphismSimplifyWithProof objC C s d (m : @ReifiedMorphism objC C s d) +: { m' : ReifiedMorphism C s d | ReifiedMorphismDenote m = ReifiedMorphismDenote m' }. +refine match m with + | ReifiedComposedMorphism _ _ s0 d0 d0' m1 m2 => _ + end; clear m. +Fail destruct (@ReifiedMorphismSimplifyWithProof _ _ _ _ m1) as [ [] ? ]. diff --git a/test-suite/bugs/opened/3071.v b/test-suite/bugs/opened/3071.v new file mode 100644 index 00000000..611ac606 --- /dev/null +++ b/test-suite/bugs/opened/3071.v @@ -0,0 +1,5 @@ +Definition foo := True. + +Section foo. + Global Arguments foo / . +Fail End foo. diff --git a/test-suite/bugs/opened/3092.v b/test-suite/bugs/opened/3092.v new file mode 100644 index 00000000..9db21d15 --- /dev/null +++ b/test-suite/bugs/opened/3092.v @@ -0,0 +1,9 @@ +Fail Fixpoint le_pred (n1 n2 : nat) (H1 : n1 <= n2) : pred n1 <= pred n2 := + match H1 with + | le_n => le_n (pred _) + | le_S _ H2 => + match n2 with + | 0 => fun H3 => H3 + | S _ => le_S _ _ + end (le_pred _ _ H2) + end. diff --git a/test-suite/bugs/opened/3100.v b/test-suite/bugs/opened/3100.v new file mode 100644 index 00000000..6f35a74d --- /dev/null +++ b/test-suite/bugs/opened/3100.v @@ -0,0 +1,9 @@ +Fixpoint F (n : nat) (A : Type) : Type := + match n with + | 0 => True + | S n => forall (x : A), F n (x = x) + end. + +Goal forall A n, (forall (x : A) (e : x = x), F n (e = e)). +intros A n. +Fail change (forall x, F n (x = x)) with (F (S n)). diff --git a/test-suite/bugs/opened/3166.v b/test-suite/bugs/opened/3166.v new file mode 100644 index 00000000..e1c29a95 --- /dev/null +++ b/test-suite/bugs/opened/3166.v @@ -0,0 +1,83 @@ +Set Asymmetric Patterns. + +Section eq. + Let A := { X : Type & X }. + Let B := (fun x : A => projT1 x). + Let T := (fun (a' : A) (b' : B a') => projT2 a' = b'). + Let T' := T. + Let t1T := (fun _ : A => unit). + Let f1 := (fun x (_ : t1T x) => projT2 x). + Let t1 := (fun x (y : t1T x) => @eq_refl (projT1 x) (projT2 x)). + Let t1T' := t1T. + Let f1' := f1. + Let t1' := t1. + + Theorem eq_matches_commute + a' b' (t' : T a' b') + (rta : forall b'', T' a' b'' -> A) + (rtb : forall b'' t'', B (rta b'' t'')) + (rt1 : forall y, T _ (rtb (f1' a' y) (@t1' a' y))) + (R : forall (b : B (rta b' t')), T _ b -> Type) + (r1 : forall y, R (f1 _ y) (@t1 _ y)) + : match + match t' as t0' in (@eq _ _ b0') return T (rta b0' t0') (rtb b0' t0') with + | eq_refl => rt1 tt + end + as t0 in (@eq _ _ b0) + return R b0 t0 + with + | eq_refl => r1 tt + end + = + match t' + as t0' in (@eq _ _ b0') + return (forall (R : forall (b : B (rta b0' t0')), T _ b -> Type) + (r1 : forall y, R (f1 _ y) (@t1 _ y)), + R _ (match t0' as t0'0 in (@eq _ _ b0'0) return T (rta b0'0 t0'0) (rtb b0'0 t0'0) with + | eq_refl => rt1 tt + end)) + with + | eq_refl => fun _ r1 => + match rt1 tt with + | eq_refl => r1 tt + end + end R r1. + Proof. + destruct t'; reflexivity. + Defined. + + Theorem eq_match_beta2 + a b (t : T a b) + X + (R : forall b' (t' : T a b'), X b' -> Type) + (r1 : forall y x, R _ (@t1 _ y) x) + x + : match t as t' in (@eq _ _ b') return forall x, R b' t' x with + | eq_refl => r1 tt + end (x b) + = + match t as t' in (@eq _ _ b') return R b' t' (x b') with + | eq_refl => r1 tt (x _) + end. + Proof. + destruct t; reflexivity. + Defined. +End eq. + +Definition typeof {T} (_ : T) := T. + +Eval compute in (eq_sym (eq_sym _)). +Goal forall T (x y : T) (p : x = y), True. + intros. + pose proof + (@eq_matches_commute + (existT (fun T => T) T x) y p + (fun b'' _ => existT (fun T => T) T b'') + (fun _ _ => x) + (fun _ => eq_refl) + (fun x' _ => x' = y) + (fun _ => eq_refl) + ) as H0. + compute in H0. + change (fun (x' : T) (_ : y = x') => x' = y) with ((fun y => fun (x' : T) (_ : y = x') => x' = y) y) in H0. + Fail pose proof (fun k => @eq_trans _ _ _ k H0). diff --git a/test-suite/bugs/opened/3186.v-disabled b/test-suite/bugs/opened/3186.v-disabled new file mode 100644 index 00000000..d0bcb920 --- /dev/null +++ b/test-suite/bugs/opened/3186.v-disabled @@ -0,0 +1,4 @@ +Fixpoint a (_:unit):= +match eq_refl with +|eq_refl => a +end.
\ No newline at end of file diff --git a/test-suite/bugs/opened/3209.v b/test-suite/bugs/opened/3209.v new file mode 100644 index 00000000..3203afa1 --- /dev/null +++ b/test-suite/bugs/opened/3209.v @@ -0,0 +1,17 @@ +Inductive eqT {A} (x : A) : A -> Type := + reflT : eqT x x. +Definition Bi_inv (A B : Type) (f : (A -> B)) := + sigT (fun (g : B -> A) => + sigT (fun (h : B -> A) => + sigT (fun (α : forall b : B, eqT (f (g b)) b) => + forall a : A, eqT (h (f a)) a))). +Definition TEquiv (A B : Type) := sigT (fun (f : A -> B) => Bi_inv _ _ f). + +Axiom UA : forall (A B : Type), TEquiv (TEquiv A B) (eqT A B). +Definition idtoeqv {A B} (e : eqT A B) : TEquiv A B := + sigT_rect (fun _ => TEquiv A B) + (fun (f : TEquiv A B -> eqT A B) H => + sigT_rect (fun _ => TEquiv A B) + (fun g _ => g e) + H) + (UA A B). diff --git a/test-suite/bugs/opened/3230.v b/test-suite/bugs/opened/3230.v new file mode 100644 index 00000000..265310b1 --- /dev/null +++ b/test-suite/bugs/opened/3230.v @@ -0,0 +1,14 @@ +Structure type : Type := Pack { ob : Type }. +Polymorphic Record category := { foo : Type }. +Definition FuncComp := Pack category. +Axiom C : category. + +Check (C : ob FuncComp). (* OK *) + +Canonical Structure FuncComp. + +Check (C : ob FuncComp). +(* Toplevel input, characters 15-39: +Error: +The term "C" has type "category" while it is expected to have type + "ob FuncComp". *) diff --git a/test-suite/bugs/opened/3248.v b/test-suite/bugs/opened/3248.v new file mode 100644 index 00000000..9e7d1eb5 --- /dev/null +++ b/test-suite/bugs/opened/3248.v @@ -0,0 +1,17 @@ +Ltac ret_and_left f := + let tac := ret_and_left in + let T := type of f in + lazymatch eval hnf in T with + | ?T' -> _ => + let ret := constr:(fun x' : T' => $(tac (f x'))$) in + exact ret + | ?T' => exact f + end. + +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)$). + Fail unify (a x y) (conj x y). +Abort. diff --git a/test-suite/bugs/opened/3263.v b/test-suite/bugs/opened/3263.v new file mode 100644 index 00000000..6de13f74 --- /dev/null +++ b/test-suite/bugs/opened/3263.v @@ -0,0 +1,231 @@ +(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *) +Generalizable All Variables. +Set Implicit Arguments. + +Arguments fst {_ _} _. +Arguments snd {_ _} _. + +Axiom cheat : forall {T}, T. + +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. + +Definition symmetry {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory (object : Type) := + Build_PreCategory' { + object :> Type := object; + morphism : object -> object -> Type; + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + associativity_sym : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + m3 o (m2 o m1) = (m3 o m2) o m1; + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + identity_identity : forall x, identity x o identity x = identity x + }. +Bind Scope category_scope with PreCategory. +Arguments PreCategory {_}. +Arguments identity {_} [!C%category] x%object : rename. + +Arguments compose {_} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Infix "o" := compose : morphism_scope. + +Delimit Scope functor_scope with functor. +Local Open Scope morphism_scope. +Record Functor `(C : @PreCategory objC, D : @PreCategory objD) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. +Bind Scope functor_scope with Functor. + +Arguments morphism_of {_} [C%category] {_} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. + +Class IsIsomorphism `{C : @PreCategory objC} {s d} (m : morphism C s d) := + { + morphism_inverse : morphism C d s; + left_inverse : morphism_inverse o m = identity _; + right_inverse : m o morphism_inverse = identity _ + }. + +Definition opposite `(C : @PreCategory objC) : PreCategory + := @Build_PreCategory' + C + (fun s d => morphism C d s) + (identity (C := C)) + (fun _ _ _ m1 m2 => m2 o m1) + (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _ _) + (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _ _) + (fun _ _ => @right_identity _ _ _ _) + (fun _ _ => @left_identity _ _ _ _) + (@identity_identity _ C). + +Notation "C ^op" := (opposite C) (at level 3) : category_scope. + +Definition prod `(C : @PreCategory objC, D : @PreCategory objD) : @PreCategory (objC * objD). + refine (@Build_PreCategory' + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) + * morphism D (snd s) (snd d))%type) + (fun x => (identity (fst x), identity (snd x))) + (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) + _ + _ + _ + _ + _); admit. +Defined. +Infix "*" := prod : category_scope. + +Definition compose_functor `(C : @PreCategory objC, D : @PreCategory objD, E : @PreCategory objE) (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)) + cheat + cheat. + +Infix "o" := compose_functor : functor_scope. + +Record NaturalTransformation `(C : @PreCategory objC, D : @PreCategory objD) (F G : Functor C D) := + Build_NaturalTransformation' { + components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), + components_of d o F _1 m = G _1 m o components_of s; + + commutes_sym : forall s d (m : C.(morphism) s d), + G _1 m o components_of s = components_of d o F _1 m + }. +Definition functor_category `(C : @PreCategory objC, D : @PreCategory objD) : PreCategory + := @Build_PreCategory' (Functor C D) + (@NaturalTransformation _ C _ D) + cheat + cheat + cheat + cheat + cheat + cheat + cheat. + +Definition opposite_functor `(F : @Functor objC C objD D) : Functor C^op D^op + := Build_Functor (C^op) (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). + +Definition opposite_invL `(F : @Functor objC C^op objD D) : Functor C D^op + := Build_Functor C (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). +Notation "F ^op" := (opposite_functor F) : functor_scope. + +Notation "F ^op'L" := (opposite_invL F) (at level 3) : functor_scope. +Definition fst `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) C + := Build_Functor (C * D) C + (@fst _ _) + (fun _ _ => @fst _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). + +Definition snd `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) D + := Build_Functor (C * D) D + (@snd _ _) + (fun _ _ => @snd _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). +Definition prod_functor `(F : @Functor objC C objD D, F' : @Functor objC C objD' D') +: Functor C (D * D') + := Build_Functor + C (D * D') + (fun c => (F c, F' c)) + (fun s d m => (F _1 m, F' _1 m))%morphism + cheat + cheat. +Definition pair `(F : @Functor objC C objD D, F' : @Functor objC' C' objD' D') : Functor (C * C') (D * D') + := (prod_functor (F o fst) (F' o snd))%functor. +Notation cat_of obj := + (@Build_PreCategory' obj + (fun x y => forall _ : x, y) + (fun _ x => x) + (fun _ _ _ f g x => f (g x))%core + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ => idpath)). + +Definition hom_functor `(C : @PreCategory objC) : Functor (C^op * C) (cat_of Type) + := Build_Functor _ _ cheat cheat cheat cheat. + +Definition induced_hom_natural_transformation `(F : @Functor objC C objD D) +: NaturalTransformation (hom_functor C) (hom_functor D o pair F^op F) + := Build_NaturalTransformation' _ _ cheat cheat cheat. + +Class IsFullyFaithful `(F : @Functor objC C objD D) + := is_fully_faithful + : forall x y : C, + IsIsomorphism (induced_hom_natural_transformation F (x, y)). + +Definition coyoneda `(A : @PreCategory objA) : Functor A^op (@functor_category _ A _ (cat_of Type)) + := cheat. + +Definition yoneda `(A : @PreCategory objA) : Functor A (@functor_category _ A^op _ (cat_of Type)) + := (((coyoneda A^op)^op'L)^op'L)%functor. +Definition coyoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@coyoneda _ A). +Admitted. + +Definition yoneda_embedding_fast `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda. + Time let t := (type of CYE) in + let t' := (eval simpl in t) in pose proof ((fun (x : t) => (x : t')) CYE) as CYE'. (* Finished transaction in 0. secs (0.216013u,0.004s) *) + Fail Timeout 1 let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). + Time let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). (* Finished transaction in 0. secs (0.248016u,0.s) *) +Fail Timeout 2 Defined. +Time Defined. (* Finished transaction in 1. secs (0.432027u,0.s) *) + +Definition yoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda; simpl in *. + Fail Timeout 1 exact CYE. + Time exact CYE. (* Finished transaction in 0. secs (0.012001u,0.s) *) +Fail Timeout 60 Defined. (* Timeout! *) diff --git a/test-suite/bugs/opened/3277.v b/test-suite/bugs/opened/3277.v new file mode 100644 index 00000000..19ed787d --- /dev/null +++ b/test-suite/bugs/opened/3277.v @@ -0,0 +1,7 @@ +Tactic Notation "evarr" open_constr(x) := let y := constr:(x) in exact y. + +Goal True. + evarr _. +Admitted. +Goal True. + Fail exact $(evarr _)$. (* Error: Cannot infer this placeholder. *) diff --git a/test-suite/bugs/opened/3278.v b/test-suite/bugs/opened/3278.v new file mode 100644 index 00000000..ced535af --- /dev/null +++ b/test-suite/bugs/opened/3278.v @@ -0,0 +1,25 @@ +Module a. + Check let x' := _ in + $(exact x')$. + + Notation foo x := (let x' := x in $(exact x')$). + + Fail Check foo _. (* Error: +Cannot infer an internal placeholder of type "Type" in environment: + +x' := ?42 : ?41 +. *) +End a. + +Module b. + Notation foo x := (let x' := x in let y := ($(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 bar _. (* let x' := ?9 in let y := I in I *) + Fail Check foo _. (* Error: +Cannot infer an internal placeholder of type "Type" in environment: + +x' := ?42 : ?41 +. *) +End b. diff --git a/test-suite/bugs/opened/3283.v b/test-suite/bugs/opened/3283.v new file mode 100644 index 00000000..3ab5416e --- /dev/null +++ b/test-suite/bugs/opened/3283.v @@ -0,0 +1,28 @@ +Notation "P |-- Q" := (@eq nat P Q) (at level 80, Q at level 41, no associativity) . +Notation "x &&& y" := (plus x y) (at level 40, left associativity, y at next level) . +Notation "'Ex' x , P " := (plus x P) (at level 65, x at level 99, P at level 80). + +(* Succeed *) +Check _ |-- _ &&& _ -> _. +Check _ |-- _ &&& (Ex _, _ ) -> _. +Check _ |-- (_ &&& Ex _, _ ) -> _. + +(* Why does this fail? *) +Fail Check _ |-- _ &&& Ex _, _ -> _. +(* The command has indeed failed with message: +=> Error: The term "Ex ?17, ?18" has type "nat" +which should be Set, Prop or Type. *) + +(* Just in case something is strange with -> *) +Notation "P ----> Q" := (P -> Q) (right associativity, at level 99, Q at next level). + +(* Succeed *) +Check _ |-- _ &&& _ ----> _. +Check _ |-- _ &&& (Ex _, _ ) ----> _. +Check _ |-- (_ &&& Ex _, _ ) ----> _. + +(* Why does this fail? *) +Fail Check _ |-- _ &&& Ex _, _ ----> _. +(* The command has indeed failed with message: +=> Error: The term "Ex ?31, ?32" has type "nat" +which should be Set, Prop or Type.*) diff --git a/test-suite/bugs/opened/3295.v b/test-suite/bugs/opened/3295.v new file mode 100644 index 00000000..2a156e33 --- /dev/null +++ b/test-suite/bugs/opened/3295.v @@ -0,0 +1,104 @@ +Require Export Morphisms Setoid. + +Class lops := lmk_ops { + car: Type; + weq: relation car +}. + +Implicit Arguments car []. + +Coercion car: lops >-> Sortclass. + +Instance weq_Equivalence `{lops}: Equivalence weq. +Proof. +Admitted. + +Module lset. +Canonical Structure lset_ops A := lmk_ops (list A) (fun h k => True). +End lset. + +Class ops := mk_ops { + ob: Type; + mor: ob -> ob -> lops; + dot: forall n m p, mor n m -> mor m p -> mor n p +}. +Coercion mor: ops >-> Funclass. +Implicit Arguments ob []. + +Instance dot_weq `{ops} n m p: Proper (weq ==> weq ==> weq) (dot n m p). +Proof. +Admitted. + +Section s. + +Import lset. + +Context `{X:lops} {I: Type}. + +Axiom sup : forall (f: I -> X) (J : list I), X. + +Global Instance sup_weq: Proper (pointwise_relation _ weq ==> weq ==> weq) sup. +Proof. +Admitted. + +End s. + +Axiom ord : forall (n : nat), Type. +Axiom seq : forall n, list (ord n). + +Infix "==" := weq (at level 79). +Infix "*" := (dot _ _ _) (left associativity, at level 40). + +Notation "∑_ ( i ∈ l ) f" := (@sup (mor _ _) _ (fun i => f) l) + (at level 41, f at level 41, i, l at level 50). + +Axiom dotxsum : forall `{X : ops} I J n m p (f: I -> X m n) (x: X p m) y, + x * (∑_(i∈ J) f i) == y. + +Definition mx X n m := ord n -> ord m -> X. + +Section bsl. +Context `{X : ops} {u: ob X}. +Notation U := (car (@mor X u u)). + +Lemma toto n m p q (M : mx U n m) N (P : mx U p q) Q i j : ∑_(j0 ∈ seq m) M i j0 * (∑_(j1 ∈ seq p) N j0 j1 * P j1 j) == Q. +Proof. + Fail setoid_rewrite dotxsum. + (* Toplevel input, characters 0-22: +Error: +Tactic failure:setoid rewrite failed: Unable to satisfy the rewriting constraints. +Unable to satisfy the following constraints: +UNDEFINED EVARS: + ?101==[X u n m p q M N P Q i j j0 |- U] (goal evar) + ?106==[X u n m p q M N P Q i j |- relation (X u u)] (internal placeholder) + ?107==[X u n m p q M N P Q i j |- relation (list (ord m))] + (internal placeholder) + ?108==[X u n m p q M N P Q i j (do_subrelation:=do_subrelation) + |- Proper (pointwise_relation (ord m) weq ==> ?107 ==> ?106) sup] + (internal placeholder) + ?109==[X u n m p q M N P Q i j |- ProperProxy ?107 (seq m)] + (internal placeholder) + ?110==[X u n m p q M N P Q i j |- relation (X u u)] (internal placeholder) + ?111==[X u n m p q M N P Q i j (do_subrelation:=do_subrelation) + |- Proper (?106 ==> ?110 ==> Basics.flip Basics.impl) weq] + (internal placeholder) + ?112==[X u n m p q M N P Q i j |- ProperProxy ?110 Q] (internal placeholder)UNIVERSES: + {} |= Top.14 <= Top.37 + Top.25 <= Top.24 + Top.25 <= Top.32 + +ALGEBRAIC UNIVERSES:{} +UNDEFINED UNIVERSES:METAS: + 470[y] := ?101 : car (?99 ?467 ?465) + 469[x] := M i _UNBOUND_REL_1 : car (?99 ?467 ?466) [type is checked] + 468[f] := fun i : ?463 => N _UNBOUND_REL_2 i * P i j : + ?463 -> ?99 ?466 ?465 [type is checked] + 467[p] := u : ob ?99 [type is checked] + 466[m] := u : ob ?99 [type is checked] + 465[n] := u : ob ?99 [type is checked] + 464[J] := seq p : list ?463 [type is checked] + 463[I] := ord p : Type [type is checked] + *) +Abort. + +End bsl. diff --git a/test-suite/bugs/opened/3298.v b/test-suite/bugs/opened/3298.v new file mode 100644 index 00000000..bce7c3f2 --- /dev/null +++ b/test-suite/bugs/opened/3298.v @@ -0,0 +1,23 @@ +Module JGross. + Hint Extern 1 => match goal with |- match ?E with end => case E end. + + Goal forall H : False, match H return Set with end. + Proof. + intros. + Fail solve [ eauto ]. (* No applicable tactic *) + admit. + Qed. +End JGross. + +Section BenDelaware. + Hint Extern 0 => admit. + Goal forall (H : False), id (match H return Set with end). + Proof. + eauto. + Qed. + Goal forall (H : False), match H return Set with end. + Proof. + Fail solve [ eauto ] . + admit. + Qed. +End BenDelaware. diff --git a/test-suite/bugs/opened/3304.v b/test-suite/bugs/opened/3304.v new file mode 100644 index 00000000..529cc737 --- /dev/null +++ b/test-suite/bugs/opened/3304.v @@ -0,0 +1,3 @@ +Fail Notation "( x , y , .. , z )" := $(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/3311.v b/test-suite/bugs/opened/3311.v new file mode 100644 index 00000000..1c66bc1e --- /dev/null +++ b/test-suite/bugs/opened/3311.v @@ -0,0 +1,10 @@ +Require Import Setoid. +Axiom bar : True = False. +Goal True. + Fail setoid_rewrite bar. (* Toplevel input, characters 15-33: +Error: +Tactic failure:setoid rewrite failed: Unable to satisfy the rewriting constraints. + +Could not find an instance for "subrelation eq (Basics.flip Basics.impl)". +With the following constraints: +?3 : "True" *) diff --git a/test-suite/bugs/opened/3312.v b/test-suite/bugs/opened/3312.v new file mode 100644 index 00000000..749921e2 --- /dev/null +++ b/test-suite/bugs/opened/3312.v @@ -0,0 +1,5 @@ +Require Import Setoid. +Axiom bar : 0 = 1. +Goal 0 = 1. + Fail rewrite_strat bar. (* Toplevel input, characters 15-32: +Error: Tactic failure:setoid rewrite failed: Nothing to rewrite. *) diff --git a/test-suite/bugs/opened/3320.v b/test-suite/bugs/opened/3320.v new file mode 100644 index 00000000..05cf7328 --- /dev/null +++ b/test-suite/bugs/opened/3320.v @@ -0,0 +1,4 @@ +Goal forall x : nat, True. + fix 1. + assumption. +Fail Qed. diff --git a/test-suite/bugs/opened/3326.v b/test-suite/bugs/opened/3326.v new file mode 100644 index 00000000..f73117a2 --- /dev/null +++ b/test-suite/bugs/opened/3326.v @@ -0,0 +1,18 @@ +Class ORDER A := Order { + LEQ : A -> A -> bool; + leqRefl: forall x, true = LEQ x x +}. + +Section XXX. + +Variable A:Type. +Variable (O:ORDER A). +Definition aLeqRefl := @leqRefl _ O. + +Lemma OK : forall x, true = LEQ x x. + intros. + unfold LEQ. + destruct O. + clear. + Fail apply aLeqRefl. (* Toplevel input, characters 15-30: +Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/opened/3343.v b/test-suite/bugs/opened/3343.v new file mode 100644 index 00000000..6c5a85f9 --- /dev/null +++ b/test-suite/bugs/opened/3343.v @@ -0,0 +1,46 @@ +(* File reduced by coq-bug-finder from original input, then from 13699 lines to 656 lines, then from 584 lines to 200 lines *) +Set Asymmetric Patterns. +Require Export Coq.Lists.List. +Export List.ListNotations. + +Record CFGV := { Terminal : Type; VarSym : Type }. + +Section Gram. + Context {G : CFGV}. + + Inductive Pattern : (Terminal G) -> Type := + | ptleaf : forall (T : Terminal G), + nat -> Pattern T + with Mixture : list (Terminal G) -> Type := + | mtcons : forall {h: Terminal G} + {tl: list (Terminal G)}, + Pattern h -> Mixture tl -> Mixture (h::tl). + + Variable vc : VarSym G. + + Fixpoint pBVars {gs} (p : Pattern gs) : (list nat) := + match p with + | ptleaf _ _ => [] + end + with mBVars {lgs} (pts : Mixture lgs) : (list nat) := + match pts with + | mtcons _ _ _ tl => mBVars tl + end. + + Lemma mBndngVarsAsNth : + forall mp (m : @Mixture mp), + mBVars m = [2]. + Proof. + intros. + induction m. progress simpl. + Admitted. +End Gram. + +Lemma mBndngVarsAsNth' {G : CFGV} { vc : VarSym G} : + forall mp (m : @Mixture G mp), + mBVars m = [2]. +Proof. + intros. + induction m. + Fail progress simpl. + (* simpl did nothing here, while it does something inside the section; this is probably a bug*) diff --git a/test-suite/bugs/opened/3345.v b/test-suite/bugs/opened/3345.v new file mode 100644 index 00000000..b61174a8 --- /dev/null +++ b/test-suite/bugs/opened/3345.v @@ -0,0 +1,144 @@ +(* File reduced by coq-bug-finder from original input, then from 1972 lines to 136 lines, then from 119 lines to 105 lines *) +Global Set Implicit Arguments. +Require Import Coq.Lists.List Program. +Section IndexBound. + Context {A : Set}. + Class IndexBound (a : A) (Bound : list A) := + { ibound :> nat; + boundi : nth_error Bound ibound = Some a}. + Global Arguments ibound [a Bound] _ . + Global Arguments boundi [a Bound] _. + Record BoundedIndex (Bound : list A) := { bindex :> A; indexb :> IndexBound bindex Bound }. +End IndexBound. +Context {A : Type} {C : Set}. +Variable (projAC : A -> C). +Lemma None_neq_Some +: forall (AnyT AnyT' : Type) (a : AnyT), + None = Some a -> AnyT'. + admit. +Defined. +Program Definition nth_Bounded' + (Bound : list A) + (c : C) + (a_opt : option A) + (nth_n : option_map projAC a_opt = Some c) +: A := match a_opt as x + return (option_map projAC x = Some c) -> A with + | Some a => fun _ => a + | None => fun f : None = Some _ => ! + end nth_n. +Lemma nth_error_map : + forall n As c_opt, + nth_error (map projAC As) n = c_opt + -> option_map projAC (nth_error As n) = c_opt. + admit. +Defined. +Definition nth_Bounded + (Bound : list A) + (idx : BoundedIndex (map projAC Bound)) +: A := nth_Bounded' Bound (nth_error Bound (ibound idx)) + (nth_error_map _ _ (boundi idx)). +Program Definition nth_Bounded_ind2 + (P : forall As, BoundedIndex (map projAC As) + -> BoundedIndex (map projAC As) + -> A -> A -> Prop) +: forall (Bound : list A) + (idx : BoundedIndex (map projAC Bound)) + (idx' : BoundedIndex (map projAC Bound)), + match nth_error Bound (ibound idx), nth_error Bound (ibound idx') with + | Some a, Some a' => P Bound idx idx' a a' + | _, _ => True + end + -> P Bound idx idx' (nth_Bounded _ idx) (nth_Bounded _ idx'):= + fun Bound idx idx' => + match (nth_error Bound (ibound idx)) as e, (nth_error Bound (ibound idx')) as e' + return + (forall (f : option_map _ e = Some (bindex idx)) + (f' : option_map _ e' = Some (bindex idx')), + (match e, e' with + | Some a, Some a' => P Bound idx idx' a a' + | _, _ => True + end) + -> P Bound idx idx' + (match e as e'' return + option_map _ e'' = Some (bindex idx) + -> A + with + | Some a => fun _ => a + | _ => fun f => _ + end f) + (match e' as e'' return + option_map _ e'' = Some (bindex idx') + -> A + with + | Some a => fun _ => a + | _ => fun f => _ + end f')) with + | Some a, Some a' => fun _ _ H => _ + | _, _ => fun f => _ + end (nth_error_map _ _ (boundi idx)) + (nth_error_map _ _ (boundi idx')). + +Lemma nth_Bounded_eq +: forall (Bound : list A) + (idx idx' : BoundedIndex (map projAC Bound)), + ibound idx = ibound idx' + -> nth_Bounded Bound idx = nth_Bounded Bound idx'. +Proof. + intros. + eapply nth_Bounded_ind2 with (idx := idx) (idx' := idx'). + simpl. + (* The [case_eq] should not Fail. More importantly, [Fail case_eq ...] should succeed if [case_eq ...] fails. It doesn't!!! So I resort to [Fail Fail try (case_eq ...)]. *) + Fail Fail try (case_eq (nth_error Bound (ibound idx'))). +(* Toplevel input, characters 15-54: +In nested Ltac calls to "case_eq" and "pattern x at - 1", last call failed. +Error: The abstracted term +"fun e : Exc A => + forall e0 : nth_error Bound (ibound idx') = e, + match + nth_error Bound (ibound idx) as anonymous'0 + return (anonymous'0 = nth_error Bound (ibound idx) -> e = e -> Prop) + with + | Some a => + match + e as anonymous' + return + (Some a = nth_error Bound (ibound idx) -> anonymous' = e -> Prop) + with + | Some a' => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : Some a' = e) => + a = a' + | None => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : None = e) => + True + end + | None => fun (_ : None = nth_error Bound (ibound idx)) (_ : e = e) => True + end eq_refl e0" is not well typed. +Illegal application: +The term + "match + nth_error Bound (ibound idx) as anonymous'0 + return (anonymous'0 = nth_error Bound (ibound idx) -> e = e -> Prop) + with + | Some a => + match + e as anonymous' + return + (Some a = nth_error Bound (ibound idx) -> anonymous' = e -> Prop) + with + | Some a' => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : Some a' = e) => + a = a' + | None => + fun (_ : Some a = nth_error Bound (ibound idx)) (_ : None = e) => + True + end + | None => fun (_ : None = nth_error Bound (ibound idx)) (_ : e = e) => True + end" of type + "nth_error Bound (ibound idx) = nth_error Bound (ibound idx) -> + e = e -> Prop" +cannot be applied to the terms + "eq_refl" : "nth_error Bound (ibound idx) = nth_error Bound (ibound idx)" + "e0" : "nth_error Bound (ibound idx') = e" +The 2nd term has type "nth_error Bound (ibound idx') = e" +which should be coercible to "e = e". *) diff --git a/test-suite/bugs/opened/3357.v b/test-suite/bugs/opened/3357.v new file mode 100644 index 00000000..c4791588 --- /dev/null +++ b/test-suite/bugs/opened/3357.v @@ -0,0 +1,9 @@ +Notation D1 := (forall {T : Type} ( x : T ) , Type). + +Definition DD1 ( A : forall {T : Type} (x : T), Type ) := A 1. +Fail Definition DD1' ( A : D1 ) := A 1. (* Toplevel input, characters 32-33: +Error: In environment +A : forall T : Type, T -> Type +The term "1" has type "nat" while it is expected to have type +"Type". + *) diff --git a/test-suite/bugs/opened/3363.v b/test-suite/bugs/opened/3363.v new file mode 100644 index 00000000..800d8957 --- /dev/null +++ b/test-suite/bugs/opened/3363.v @@ -0,0 +1,26 @@ +(** In this file, either all four [Check]s should fail, or all four should succeed. *) +Module A. + Section HexStrings. + Require Import String. + End HexStrings. + Fail Check string. +End A. + +Module B. + Section HexStrings. + Require String. + Import String. + End HexStrings. + Fail Check string. +End B. + +Section HexStrings. + Require String. + Import String. +End HexStrings. +Fail Check string. + +Section HexStrings'. + Require Import String. +End HexStrings'. +Check string. diff --git a/test-suite/bugs/opened/3370.v b/test-suite/bugs/opened/3370.v new file mode 100644 index 00000000..4964bf96 --- /dev/null +++ b/test-suite/bugs/opened/3370.v @@ -0,0 +1,12 @@ +Require Import String. + +Local Ltac set_strings := + let s := match goal with |- context[String ?s1 ?s2] => constr:(String s1 s2) end in + let H := fresh s in + set (H := s). + +Local Open Scope string_scope. + +Goal "asdf" = "bds". +Fail set_strings. (* Error: Ltac variable s is bound to "asdf" which cannot be coerced to +a fresh identifier. *) diff --git a/test-suite/bugs/opened/3383.v b/test-suite/bugs/opened/3383.v new file mode 100644 index 00000000..9a14641a --- /dev/null +++ b/test-suite/bugs/opened/3383.v @@ -0,0 +1,7 @@ +Goal forall b : bool, match b as b' return if b' then True else True with true => I | false => I end = match b as b' return if b' then True else True with true => I | false => I end. +intro. +Fail lazymatch goal with +| [ |- appcontext[match ?b as b' return @?P b' with true => ?t | false => ?f end] ] + => change (match b as b' return P b with true => t | false => f end) with (@bool_rect P t f) +end. (* Toplevel input, characters 153-154: +Error: The reference P was not found in the current environment. *) diff --git a/test-suite/bugs/opened/3395.v b/test-suite/bugs/opened/3395.v new file mode 100644 index 00000000..ff0dbf97 --- /dev/null +++ b/test-suite/bugs/opened/3395.v @@ -0,0 +1,230 @@ +(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *) +Generalizable All Variables. +Set Implicit Arguments. + +Arguments fst {_ _} _. +Arguments snd {_ _} _. + +Axiom cheat : forall {T}, T. + +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. + +Definition symmetry {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory (object : Type) := + Build_PreCategory' { + object :> Type := object; + morphism : object -> object -> Type; + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + associativity_sym : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + m3 o (m2 o m1) = (m3 o m2) o m1; + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + identity_identity : forall x, identity x o identity x = identity x + }. +Bind Scope category_scope with PreCategory. +Arguments PreCategory {_}. +Arguments identity {_} [!C%category] x%object : rename. + +Arguments compose {_} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. + +Infix "o" := compose : morphism_scope. + +Delimit Scope functor_scope with functor. +Local Open Scope morphism_scope. +Record Functor `(C : @PreCategory objC, D : @PreCategory objD) := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. +Bind Scope functor_scope with Functor. + +Arguments morphism_of {_} [C%category] {_} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. + +Class IsIsomorphism `{C : @PreCategory objC} {s d} (m : morphism C s d) := + { + morphism_inverse : morphism C d s; + left_inverse : morphism_inverse o m = identity _; + right_inverse : m o morphism_inverse = identity _ + }. + +Definition opposite `(C : @PreCategory objC) : PreCategory + := @Build_PreCategory' + C + (fun s d => morphism C d s) + (identity (C := C)) + (fun _ _ _ m1 m2 => m2 o m1) + (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _ _) + (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _ _) + (fun _ _ => @right_identity _ _ _ _) + (fun _ _ => @left_identity _ _ _ _) + (@identity_identity _ C). + +Notation "C ^op" := (opposite C) (at level 3) : category_scope. + +Definition prod `(C : @PreCategory objC, D : @PreCategory objD) : @PreCategory (objC * objD). + refine (@Build_PreCategory' + (C * D)%type + (fun s d => (morphism C (fst s) (fst d) + * morphism D (snd s) (snd d))%type) + (fun x => (identity (fst x), identity (snd x))) + (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) + _ + _ + _ + _ + _); admit. +Defined. +Infix "*" := prod : category_scope. + +Definition compose_functor `(C : @PreCategory objC, D : @PreCategory objD, E : @PreCategory objE) (G : Functor D E) (F : Functor C D) : Functor C E + := Build_Functor + C E + (fun c => G (F c)) + (fun _ _ m => morphism_of G (morphism_of F m)) + cheat + cheat. + +Infix "o" := compose_functor : functor_scope. + +Record NaturalTransformation `(C : @PreCategory objC, D : @PreCategory objD) (F G : Functor C D) := + Build_NaturalTransformation' { + components_of :> forall c, morphism D (F c) (G c); + commutes : forall s d (m : morphism C s d), + components_of d o F _1 m = G _1 m o components_of s; + + commutes_sym : forall s d (m : C.(morphism) s d), + G _1 m o components_of s = components_of d o F _1 m + }. +Definition functor_category `(C : @PreCategory objC, D : @PreCategory objD) : PreCategory + := @Build_PreCategory' (Functor C D) + (@NaturalTransformation _ C _ D) + cheat + cheat + cheat + cheat + cheat + cheat + cheat. + +Definition opposite_functor `(F : @Functor objC C objD D) : Functor C^op D^op + := Build_Functor (C^op) (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). + +Definition opposite_invL `(F : @Functor objC C^op objD D) : Functor C D^op + := Build_Functor C (D^op) + (object_of F) + (fun s d => morphism_of F (s := d) (d := s)) + (fun d' d s m1 m2 => composition_of F s d d' m2 m1) + (identity_of F). +Notation "F ^op" := (opposite_functor F) : functor_scope. + +Notation "F ^op'L" := (opposite_invL F) (at level 3) : functor_scope. +Definition fst `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) C + := Build_Functor (C * D) C + (@fst _ _) + (fun _ _ => @fst _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). + +Definition snd `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) D + := Build_Functor (C * D) D + (@snd _ _) + (fun _ _ => @snd _ _) + (fun _ _ _ _ _ => idpath) + (fun _ => idpath). +Definition prod_functor `(F : @Functor objC C objD D, F' : @Functor objC C objD' D') +: Functor C (D * D') + := Build_Functor + C (D * D') + (fun c => (F c, F' c)) + (fun s d m => (F _1 m, F' _1 m))%morphism + cheat + cheat. +Definition pair `(F : @Functor objC C objD D, F' : @Functor objC' C' objD' D') : Functor (C * C') (D * D') + := (prod_functor (F o fst) (F' o snd))%functor. +Notation cat_of obj := + (@Build_PreCategory' obj + (fun x y => forall _ : x, y) + (fun _ x => x) + (fun _ _ _ f g x => f (g x))%core + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ => idpath)). + +Definition hom_functor `(C : @PreCategory objC) : Functor (C^op * C) (cat_of Type) + := Build_Functor _ _ cheat cheat cheat cheat. + +Definition induced_hom_natural_transformation `(F : @Functor objC C objD D) +: NaturalTransformation (hom_functor C) (hom_functor D o pair F^op F) + := Build_NaturalTransformation' _ _ cheat cheat cheat. + +Class IsFullyFaithful `(F : @Functor objC C objD D) + := is_fully_faithful + : forall x y : C, + IsIsomorphism (induced_hom_natural_transformation F (x, y)). + +Definition coyoneda `(A : @PreCategory objA) : Functor A^op (@functor_category _ A _ (cat_of Type)) + := cheat. + +Definition yoneda `(A : @PreCategory objA) : Functor A (@functor_category _ A^op _ (cat_of Type)) + := (((coyoneda A^op)^op'L)^op'L)%functor. +Definition coyoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@coyoneda _ A). +Admitted. + +Definition yoneda_embedding_fast `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda. + Time let t := (type of CYE) in + let t' := (eval simpl in t) in pose proof ((fun (x : t) => (x : t')) CYE) as CYE'. (* Finished transaction in 0. secs (0.216013u,0.004s) *) + Fail Timeout 1 let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). + Time let t := match goal with |- ?G => constr:(G) end in + let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). (* Finished transaction in 0. secs (0.248016u,0.s) *) +Fail Timeout 2 Defined. +Time Defined. (* Finished transaction in 1. secs (0.432027u,0.s) *) + +Definition yoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). +Proof. + intros a b. + pose proof (coyoneda_embedding A^op a b) as CYE. + unfold yoneda; simpl in *. + Fail Timeout 1 exact CYE. + Time exact CYE. (* Finished transaction in 0. secs (0.012001u,0.s) *) diff --git a/test-suite/bugs/opened/3410.v b/test-suite/bugs/opened/3410.v new file mode 100644 index 00000000..0d259181 --- /dev/null +++ b/test-suite/bugs/opened/3410.v @@ -0,0 +1 @@ +Fail repeat match goal with H:_ |- _ => setoid_rewrite X in H end. diff --git a/test-suite/bugs/opened/3459.v b/test-suite/bugs/opened/3459.v new file mode 100644 index 00000000..9e6107b3 --- /dev/null +++ b/test-suite/bugs/opened/3459.v @@ -0,0 +1,31 @@ +(* Bad interaction between clear and the typability of ltac constr bindings *) + +(* Original report *) + +Goal 1 = 2. +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 + clear x; + exact r)$) in + pose y +end. +(* Add extra test for typability (should not fail when bug closed) *) +Fail match goal with P:?c |- _ => try (let x := type of c in idtac) || fail 2 end. +Abort. + +(* Second report raising a Not_found at the time of 21 Oct 2014 *) + +Section F. + +Variable x : nat. + +Goal True. +evar (e : Prop). +assert e. +Fail let r := constr:(eq_refl x) in clear x; exact r. +Abort. + +End F. diff --git a/test-suite/bugs/opened/3461.v b/test-suite/bugs/opened/3461.v new file mode 100644 index 00000000..1b625e6a --- /dev/null +++ b/test-suite/bugs/opened/3461.v @@ -0,0 +1,5 @@ +Lemma foo (b : bool) : + exists x : nat, x = x. +Proof. +eexists. +Fail eexact (eq_refl b). diff --git a/test-suite/bugs/opened/3463.v b/test-suite/bugs/opened/3463.v new file mode 100644 index 00000000..541db37f --- /dev/null +++ b/test-suite/bugs/opened/3463.v @@ -0,0 +1,13 @@ +Tactic Notation "test1" open_constr(t) ident(r):= + pose t. +Tactic Notation "test2" constr(r) open_constr(t):= + pose t. +Tactic Notation "test3" open_constr(t) constr(r):= + pose t. + +Goal True. + test1 (1 + _) nat. + test2 nat (1 + _). + test3 (1 + _) nat. + test3 (1 + _ : nat) nat. + diff --git a/test-suite/bugs/opened/3467.v b/test-suite/bugs/opened/3467.v new file mode 100644 index 00000000..900bfc34 --- /dev/null +++ b/test-suite/bugs/opened/3467.v @@ -0,0 +1,6 @@ +Module foo. + Notation x := $(exact I)$. +End foo. +Module bar. + Fail Include foo. +End bar. diff --git a/test-suite/bugs/opened/3478.v-disabled b/test-suite/bugs/opened/3478.v-disabled new file mode 100644 index 00000000..cc926b21 --- /dev/null +++ b/test-suite/bugs/opened/3478.v-disabled @@ -0,0 +1,8 @@ +Set Primitive Projections. +Record foo := { foom :> Type }. +Canonical Structure default_foo := fun T => {| foom := T |}. +Record bar T := { bar1 : T }. +Goal forall (s : foo) (x : foom s), True. +Proof. + intros. + Timeout 1 pose (x : bar _) as x'.
\ No newline at end of file diff --git a/test-suite/bugs/opened/3490.v b/test-suite/bugs/opened/3490.v new file mode 100644 index 00000000..e7a5caa1 --- /dev/null +++ b/test-suite/bugs/opened/3490.v @@ -0,0 +1,27 @@ +Inductive T : Type := +| Var : nat -> T +| Arr : T -> T -> T. + +Inductive Tele : list T -> Type := +| Tnil : @Tele nil +| Tcons : forall ls, forall (t : @Tele ls) (l : T), @Tele (l :: ls). + +Fail Fixpoint TeleD (ls : list T) (t : Tele ls) {struct t} + : { x : Type & x -> nat -> Type } := + match t return { x : Type & x -> nat -> Type } with + | Tnil => @existT Type (fun x => x -> nat -> Type) unit (fun (_ : unit) (_ : nat) => unit) + | Tcons ls t' l => + let (result, get) := TeleD ls t' in + @existT Type (fun x => x -> nat -> Type) + { v : result & (fix TD (t : T) {struct t} := + match t with + | Var n => + get v n + | Arr a b => TD a -> TD b + end) l } + (fun x n => + match n return Type with + | 0 => projT2 x + | S n => get (projT1 x) n + end) + end. diff --git a/test-suite/bugs/opened/3491.v b/test-suite/bugs/opened/3491.v new file mode 100644 index 00000000..9837b0ec --- /dev/null +++ b/test-suite/bugs/opened/3491.v @@ -0,0 +1,2 @@ +Fail Inductive list (A : Type) (T := A) : Type := + nil : list A | cons : T -> list T -> list A. diff --git a/test-suite/bugs/opened/3509.v b/test-suite/bugs/opened/3509.v new file mode 100644 index 00000000..02e47a8b --- /dev/null +++ b/test-suite/bugs/opened/3509.v @@ -0,0 +1,18 @@ +Lemma match_bool_fn b A B xT xF +: match b as b return forall x : A, B b x with + | true => xT + | false => xF + end + = fun x : A => match b as b return B b x with + | true => xT x + | false => xF x + end. +admit. +Defined. +Lemma match_bool_comm_1 (b : bool) A B (F : forall x : A, B x) t f +: (if b as b return B (if b then t else f) then F t else F f) + = F (if b then t else f). +admit. +Defined. +Hint Rewrite match_bool_fn : matchdb. +Fail Hint Rewrite match_bool_comm_1 : matchdb. diff --git a/test-suite/bugs/opened/3510.v b/test-suite/bugs/opened/3510.v new file mode 100644 index 00000000..25285636 --- /dev/null +++ b/test-suite/bugs/opened/3510.v @@ -0,0 +1,34 @@ +Lemma match_option_fn T (b : option T) A B s n +: match b as b return forall x : A, B b x with + | Some k => s k + | None => n + end + = fun x : A => match b as b return B b x with + | Some k => s k x + | None => n x + end. +admit. +Defined. +Lemma match_option_comm_2 T (p : option T) A B R (f : forall (x : A) (y : B x), R x y) (s1 : T -> A) (s2 : forall x : T, B (s1 x)) n1 n2 +: match p as p return R match p with + | Some k => s1 k + | None => n1 + end + match p as p return B match p with Some k => s1 k | None => n1 end with + | Some k => s2 k + | None => n2 + end with + | Some k => f (s1 k) (s2 k) + | None => f n1 n2 + end + = f match p return A with + | Some k => s1 k + | None => n1 + end + match p as p return B match p with Some k => s1 k | None => n1 end with + | Some k => s2 k + | None => n2 + end. +admit. +Defined. +Fail Hint Rewrite match_option_fn match_option_comm_2 : matchdb. diff --git a/test-suite/bugs/opened/3554.v b/test-suite/bugs/opened/3554.v new file mode 100644 index 00000000..422c5770 --- /dev/null +++ b/test-suite/bugs/opened/3554.v @@ -0,0 +1 @@ +Fail Example foo (f : forall {_ : Type}, Type) : Type. diff --git a/test-suite/bugs/opened/3562.v b/test-suite/bugs/opened/3562.v new file mode 100644 index 00000000..04a1223b --- /dev/null +++ b/test-suite/bugs/opened/3562.v @@ -0,0 +1,2 @@ +Theorem t: True. +Fail destruct 0 as x. diff --git a/test-suite/bugs/opened/3626.v b/test-suite/bugs/opened/3626.v new file mode 100644 index 00000000..46a6c009 --- /dev/null +++ b/test-suite/bugs/opened/3626.v @@ -0,0 +1,7 @@ +Set Implicit Arguments. +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. + +Fail Goal forall x y : prod Set Set, x.(@fst) = y.(@fst). +(* intros. + apply f_equal. *) diff --git a/test-suite/bugs/opened/3655.v b/test-suite/bugs/opened/3655.v new file mode 100644 index 00000000..841f77fe --- /dev/null +++ b/test-suite/bugs/opened/3655.v @@ -0,0 +1,9 @@ +Ltac bar x := pose x. +Tactic Notation "foo" open_constr(x) := bar x. +Class baz := { baz' : Type }. +Goal True. +(* Original error was an anomaly which is fixed; now, it succeeds but + leaving an evar, while calling pose would not leave an evar, so I + guess it is still a bug in the sense that the semantics of pose is + not preserved *) + foo baz'. diff --git a/test-suite/bugs/opened/3657.v b/test-suite/bugs/opened/3657.v new file mode 100644 index 00000000..6faec076 --- /dev/null +++ b/test-suite/bugs/opened/3657.v @@ -0,0 +1,33 @@ +(* Set Primitive Projections. *) +Class foo {A} {a : A} := { bar := a; baz : bar = bar }. +Arguments bar {_} _ {_}. +Instance: forall A a, @foo A a. +intros; constructor. +abstract reflexivity. +Defined. +Goal @bar _ Set _ = (@bar _ (fun _ : Set => Set) _) nat. +Proof. + Check (bar Set). + Check (bar (fun _ : Set => Set)). + Fail change (bar (fun _ : Set => Set)) with (bar Set). (* Error: Conversion test raised an anomaly *) + +Abort. + + +Module A. +Universes i j. +Constraint i < j. +Variable foo : Type@{i}. +Goal Type@{i}. + Fail let t := constr:(Type@{j}) in + change Type with t. +Abort. + +Goal Type@{j}. + Fail let t := constr:(Type@{i}) in + change Type with t. + let t := constr:(Type@{i}) in + change t. exact foo. +Defined. + +End A. diff --git a/test-suite/bugs/opened/3670.v b/test-suite/bugs/opened/3670.v new file mode 100644 index 00000000..cf5e9b09 --- /dev/null +++ b/test-suite/bugs/opened/3670.v @@ -0,0 +1,19 @@ +Module Type FOO. + Parameters P Q : Type -> Type. +End FOO. + +Module Type BAR. + Declare Module Export foo : FOO. + Parameter f : forall A, P A -> Q A -> A. +End BAR. + +Module Type BAZ. + Declare Module Export foo : FOO. + Parameter g : forall A, P A -> Q A -> A. +End BAZ. + +Module BAR_FROM_BAZ (baz : BAZ) : BAR. + Import baz. + Module foo <: FOO := foo. + Definition f : forall A, P A -> Q A -> A := g. +End BAR_FROM_BAZ. diff --git a/test-suite/bugs/opened/3675.v b/test-suite/bugs/opened/3675.v new file mode 100644 index 00000000..93227ab8 --- /dev/null +++ b/test-suite/bugs/opened/3675.v @@ -0,0 +1,20 @@ +Set Primitive Projections. +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +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 "p @ q" := (concat p q) (at level 20) : path_scope. +Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. +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) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. +Local Open Scope path_scope. +Local Open Scope equiv_scope. +Generalizable Variables A B C f g. +Lemma isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} +: IsEquiv (compose g f). +Proof. + refine (Build_IsEquiv A C + (compose g f) + (compose f^-1 g^-1) _). + exact (fun c => ap g (@eisretr _ _ f _ (g^-1 c)) @ (@eisretr _ _ g _ c)). diff --git a/test-suite/bugs/opened/3681.v b/test-suite/bugs/opened/3681.v new file mode 100644 index 00000000..194113c6 --- /dev/null +++ b/test-suite/bugs/opened/3681.v @@ -0,0 +1,20 @@ +Module Type FOO. + Parameters P Q : Type -> Type. +End FOO. + +Module Type BAR. + Declare Module Import foo : FOO. + Parameter f : forall A, P A -> Q A -> A. +End BAR. + +Module Type BAZ. + Declare Module Export foo : FOO. + Parameter g : forall A, P A -> Q A -> A. +End BAZ. + +Module BAR_FROM_BAZ (baz : BAZ) : BAR. + Import baz. + Module foo <: FOO := foo. + Import foo. + Definition f : forall A, P A -> Q A -> A := g. +End BAR_FROM_BAZ. diff --git a/test-suite/bugs/opened/3685.v b/test-suite/bugs/opened/3685.v new file mode 100644 index 00000000..d647b5a8 --- /dev/null +++ b/test-suite/bugs/opened/3685.v @@ -0,0 +1,74 @@ +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 _ _ _ _). diff --git a/test-suite/bugs/opened/3753.v b/test-suite/bugs/opened/3753.v new file mode 100644 index 00000000..05d77c83 --- /dev/null +++ b/test-suite/bugs/opened/3753.v @@ -0,0 +1,4 @@ +Axiom foo : Type -> Type. +Axiom bar : forall (T : Type), T -> foo T. +Arguments bar A x : rename. +Fail About bar. diff --git a/test-suite/bugs/opened/3754.v b/test-suite/bugs/opened/3754.v new file mode 100644 index 00000000..c7441882 --- /dev/null +++ b/test-suite/bugs/opened/3754.v @@ -0,0 +1,282 @@ +(* 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 + coqtop version trunk (October 2014) *) + +Notation Type0 := Set. + +Notation idmap := (fun x => x). + +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. + +Notation pr1 := projT1. + +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. + +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := + fun x => g (f x). + +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. +Open Scope 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. +admit. +Defined. + +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 q) (at level 20) : path_scope. + +Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope. + +Notation "p @' q" := (concat p q) (at level 21, left associativity, + format "'[v' p '/' '@'' q ']'") : long_path_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y. +exact (match p with idpath => u end). +Defined. + +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. +exact (match p with idpath => idpath end). +Defined. + +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} f {_} _. + +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) : equiv_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. + +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. + +Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope. +Local Open Scope trunc_scope. +Notation "-2" := minus_two (at level 0) : trunc_scope. +Notation "-1" := (-2.+1) (at level 0) : 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. +Notation IsHProp := (IsTrunc -1). + +Monomorphic Axiom dummy_funext_type : Type0. +Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }. + +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 moveL_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) : + r^ @ q = p -> q = r @ p. +admit. +Defined. + +Ltac with_rassoc tac := + repeat rewrite concat_pp_p; + tac; + + repeat rewrite concat_p_pp. + +Ltac rewrite_moveL_Mp_p := with_rassoc ltac:(apply moveL_Mp). + +Definition ap_p_pp {A B : Type} (f : A -> B) {w : B} {x y z : A} + (r : w = f x) (p : x = y) (q : y = z) : + r @ (ap f (p @ q)) = (r @ ap f p) @ (ap f q). +admit. +Defined. + +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_Ap {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) : + (ap f q) @ (p y) = (p x) @ (ap g q) + := + match q with + | idpath => concat_1p _ @ ((concat_p1 _) ^) + end. + +Definition transportD2 {A : Type} (B C : A -> Type) (D : forall a:A, B a -> C a -> Type) + {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D x1 y z) + : D x2 (p # y) (p # z) + := + match p with idpath => w end. +Local Open Scope equiv_scope. + +Definition transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} + {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) (y : B x2) + : (transport (fun x => B x -> C) p f) y = f (p^ # y). +admit. +Defined. + +Definition transport_arrow_fromconst {A B : Type} {C : A -> Type} + {x1 x2 : A} (p : x1 = x2) (f : B -> C x1) (y : B) + : (transport (fun x => B -> C x) p f) y = p # (f y). +admit. +Defined. + +Definition ap_transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type} + {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) {y1 y2 : B x2} (q : y1 = y2) + : ap (transport (fun x => B x -> C) p f) q + @ transport_arrow_toconst p f y2 + = transport_arrow_toconst p f y1 + @ ap (fun y => f (p^ # y)) q. +admit. +Defined. + +Class Univalence. +Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B). +admit. +Defined. +Definition transport_path_universe + {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A) + : transport (fun X:Type => X) (path_universe f) z = f z. +admit. +Defined. +Definition transport_path_universe_V `{Funext} + {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : B) + : transport (fun X:Type => X) (path_universe f)^ z = f^-1 z. +admit. +Defined. + +Ltac simpl_do_clear tac term := + let H := fresh in + assert (H := term); + simpl in H |- *; + tac H; + clear H. + +Tactic Notation "simpl" "rewrite" constr(term) := simpl_do_clear ltac:(fun H => rewrite H) term. + +Global Instance Univalence_implies_Funext `{Univalence} : Funext. +Admitted. + +Section Factorization. + + Context {class1 class2 : forall (X Y : Type@{i}), (X -> Y) -> Type@{i}} + `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class1 _ _ g)} + `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class2 _ _ g)} + {A B : Type@{i}} {f : A -> B}. + + Record Factorization := + { intermediate : Type ; + factor1 : A -> intermediate ; + factor2 : intermediate -> B ; + fact_factors : factor2 o factor1 == f ; + inclass1 : class1 _ _ factor1 ; + inclass2 : class2 _ _ factor2 + }. + + Record PathFactorization {fact fact' : Factorization} := + { path_intermediate : intermediate fact <~> intermediate fact' ; + path_factor1 : path_intermediate o factor1 fact == factor1 fact' ; + path_factor2 : factor2 fact == factor2 fact' o path_intermediate ; + path_fact_factors : forall a, path_factor2 (factor1 fact a) + @ ap (factor2 fact') (path_factor1 a) + @ fact_factors fact' a + = fact_factors fact a + }. + Context `{Univalence} {fact fact' : Factorization} + (pf : @PathFactorization fact fact'). + + Let II := path_intermediate pf. + Let ff1 := path_factor1 pf. + Let ff2 := path_factor2 pf. +Local Definition II' : intermediate fact = intermediate fact'. +admit. +Defined. + + Local Definition fff' (a : A) + : (transportD2 (fun X => A -> X) (fun X => X -> B) + (fun X g h => {_ : forall a : A, h (g a) = f a & + {_ : class1 A X g & class2 X B h}}) + II' (factor1 fact) (factor2 fact) + (fact_factors fact; (inclass1 fact; inclass2 fact))).1 a = + ap (transport (fun X => X -> B) II' (factor2 fact)) + (transport_arrow_fromconst II' (factor1 fact) a + @ transport_path_universe II (factor1 fact a) + @ ff1 a) + @ transport_arrow_toconst II' (factor2 fact) (factor1 fact' a) + @ ap (factor2 fact) (transport_path_universe_V II (factor1 fact' a)) + @ ff2 (II^-1 (factor1 fact' a)) + @ ap (factor2 fact') (eisretr II (factor1 fact' a)) + @ fact_factors fact' a. + Proof. + + Open Scope long_path_scope. + + rewrite (ap_transport_arrow_toconst (B := idmap) (C := B)). + + simpl rewrite (@ap_compose _ _ _ (transport idmap (path_universe II)^) + (factor2 fact)). + rewrite <- ap_p_pp; rewrite_moveL_Mp_p. + Set Debug Tactic Unification. + Fail rewrite (concat_Ap ff2). diff --git a/test-suite/bugs/opened/3786.v b/test-suite/bugs/opened/3786.v new file mode 100644 index 00000000..5a124115 --- /dev/null +++ b/test-suite/bugs/opened/3786.v @@ -0,0 +1,40 @@ +Require Coq.Lists.List. +Require Coq.Sets.Ensembles. +Import Coq.Sets.Ensembles. +Global Set Implicit Arguments. +Delimit Scope comp_scope with comp. +Inductive Comp : Type -> Type := +| Return : forall A, A -> Comp A +| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B +| Pick : forall A, Ensemble A -> Comp A. +Notation ret := Return. +Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp)) + (at level 81, right associativity, + format "'[v' x <- y ; '/' z ']'") : comp_scope. +Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop. +Open Scope comp. +Axiom elements : forall {A} (ls : list A), Ensemble A. +Axiom to_list : forall {A} (S : Ensemble A), Comp (list A). +Axiom finite_set_handle_cardinal : refine (ret 0) (ret 0). +Definition sumUniqueSpec (ls : list nat) : Comp nat. + exact (ls' <- to_list (elements ls); + List.fold_right (fun a b' => Bind b' ((fun a b => ret (a + b)) a)) (ret 0) ls'). +Defined. +Axiom admit : forall {T}, T. +Definition sumUniqueImpl (ls : list nat) +: { c : _ | refine (sumUniqueSpec ls) (ret c) }%type. +Proof. + eexists. + match goal with + | [ |- refine ?a ?b ] => let a' := eval hnf in a in refine (_ : refine a' b) + end; + try setoid_rewrite (@finite_set_handle_cardinal). + Undo. + match goal with + | [ |- refine ?a ?b ] => let a' := eval hnf in a in change (refine a' b) + end. + try setoid_rewrite (@finite_set_handle_cardinal). (* Anomaly: Uncaught exception Invalid_argument("decomp_pointwise"). +Please report. *) + instantiate (1 := admit). + admit. +Defined. diff --git a/test-suite/bugs/opened/3788.v b/test-suite/bugs/opened/3788.v new file mode 100644 index 00000000..8e605a00 --- /dev/null +++ b/test-suite/bugs/opened/3788.v @@ -0,0 +1,5 @@ +Set Implicit Arguments. +Global Set Primitive Projections. +Record Functor (C D : Type) := { object_of :> forall _ : C, D }. +Axiom path_functor_uncurried : forall C D (F G : Functor C D) (_ : sigT (fun HO : object_of F = object_of G => Set)), F = G. +Fail Lemma path_functor_uncurried_snd C D F G HO HM : (@path_functor_uncurried C D F G (existT _ HO HM)) = HM. diff --git a/test-suite/bugs/opened/3808.v b/test-suite/bugs/opened/3808.v new file mode 100644 index 00000000..df40ca19 --- /dev/null +++ b/test-suite/bugs/opened/3808.v @@ -0,0 +1,2 @@ +Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i}) + := foo : Foo. diff --git a/test-suite/bugs/opened/3819.v b/test-suite/bugs/opened/3819.v new file mode 100644 index 00000000..7105a658 --- /dev/null +++ b/test-suite/bugs/opened/3819.v @@ -0,0 +1,11 @@ +Set Universe Polymorphism. + +Record Op := { t : Type ; op : t -> t }. + +Canonical Structure OpType : Op := Build_Op Type (fun X => X). + +Lemma test1 (X:Type) : eq (op OpType X) X. +Proof eq_refl. + +Lemma test2 (A:Type) : eq (op _ A) A. +Fail Proof eq_refl. diff --git a/test-suite/bugs/opened/3849.v b/test-suite/bugs/opened/3849.v new file mode 100644 index 00000000..5290054a --- /dev/null +++ b/test-suite/bugs/opened/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. +Fail bar n3 n4. diff --git a/test-suite/bugs/opened/shouldnotfail/743.v b/test-suite/bugs/opened/743.v index f1eee6c1..28257014 100644 --- a/test-suite/bugs/opened/shouldnotfail/743.v +++ b/test-suite/bugs/opened/743.v @@ -7,6 +7,6 @@ Qed. Lemma foo' : forall n m : nat, n <= n + n * m. Proof. - intros. omega. -Qed. + intros. Fail omega. +Abort. diff --git a/test-suite/bugs/opened/HoTT_coq_106.v b/test-suite/bugs/opened/HoTT_coq_106.v new file mode 100644 index 00000000..a5664595 --- /dev/null +++ b/test-suite/bugs/opened/HoTT_coq_106.v @@ -0,0 +1,52 @@ +(* File reduced by coq-bug-finder from 520 lines to 9 lines. *) +Set Universe Polymorphism. +Class IsPointed (A : Type) := point : A. + +Generalizable Variables A B f. + +Instance ispointed_forall `{H : forall a : A, IsPointed (B a)} +: IsPointed (forall a, B a) + := fun a => @point (B a) (H a). + +Instance ispointed_sigma `{IsPointed A} `{IsPointed (B (point A))} +: IsPointed (sigT B). +(* Message was at some time: +Toplevel input, characters 20-108: +Error: Unable to satisfy the following constraints: +UNDEFINED EVARS: + ?8==[A H B |- IsPointed (forall x : Type, ?13)] (parameter IsPointed of + @point) + ?12==[A H {B} x |- Type] (parameter A of @point) + ?13==[A H {B} x |- Type] (parameter A of @point) + ?15==[A H {B} x |- Type] (parameter A of @point)UNIVERSES: + {Top.38 Top.30 Top.39 Top.40 Top.29 Top.36 Top.31 Top.35 Top.37 Top.34 Top.32 Top.33} |= Top.30 < Top.29 + Top.30 < Top.36 + Top.32 < Top.34 + Top.38 <= Top.37 + Top.38 <= Top.33 + Top.40 <= Top.38 + Top.40 <= Coq.Init.Specif.7 + Top.40 <= Top.39 + Top.36 <= Top.35 + Top.37 <= Top.35 + Top.34 <= Top.31 + Top.32 <= Top.39 + Top.32 <= Coq.Init.Specif.8 + Top.33 <= Top.31 + +ALGEBRAIC UNIVERSES: + {Top.38 Top.40 Top.29 Top.36 Top.31 Top.37 Top.34 Top.33} +UNDEFINED UNIVERSES: + Top.38 + Top.30 + Top.39 + Top.40 + Top.29 + Top.36 + Top.31 + Top.35 + Top.37 + Top.34 + Top.32 + Top.33CONSTRAINTS:[] [A H B] |- ?13 == ?12 +[] [A H B H0] |- ?12 == ?15 *) diff --git a/test-suite/bugs/opened/HoTT_coq_120.v b/test-suite/bugs/opened/HoTT_coq_120.v new file mode 100644 index 00000000..7847c5e4 --- /dev/null +++ b/test-suite/bugs/opened/HoTT_coq_120.v @@ -0,0 +1,136 @@ +(* 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). *) diff --git a/test-suite/bugs/opened/shouldnotfail/2310.v b/test-suite/bugs/opened/shouldnotfail/2310.v deleted file mode 100644 index 8d1a5149..00000000 --- a/test-suite/bugs/opened/shouldnotfail/2310.v +++ /dev/null @@ -1,17 +0,0 @@ -(* Dependent higher-order hole in "refine" (simplified version) *) - -Set Implicit Arguments. - -Inductive Nest t := Cons : Nest (prod t t) -> Nest t. - -Definition cast A x y Heq P H := @eq_rect A x P H y Heq. - -Definition replace a (y:Nest (prod a a)) : a = a -> Nest a. - -(* This used to raise an anomaly Unknown Meta in 8.2 and 8.3beta. - It raises a regular error in 8.3 and almost succeeds with the new - proof engine: there are two solutions to a unification problem - (P:=\a.Nest (prod a a) and P:=\_.Nest (prod a a)) and refine should either - leave P as subgoal or choose itself one solution *) - -intros. refine (Cons (cast H _ y)). |