Inductives in SProp, forbid primitive records with only sprop fields

For nonsquashed:
Either
- 0 constructors
- primitive record

2 files changed, 154 insertions, 18 deletions

diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out
index f4544a0df3..ffba1d35cc 100644
--- a/test-suite/output/Search.out
+++ b/test-suite/output/Search.out
@@ -1,59 +1,72 @@
 le_n: forall n : nat, n <= n
 le_0_n: forall n : nat, 0 <= n
 le_S: forall n m : nat, n <= m -> n <= S m
-le_n_S: forall n m : nat, n <= m -> S n <= S m
-le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m
 le_S_n: forall n m : nat, S n <= S m -> n <= m
-min_l: forall n m : nat, n <= m -> Nat.min n m = n
+le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m
+le_n_S: forall n m : nat, n <= m -> S n <= S m
+max_l: forall n m : nat, m <= n -> Nat.max n m = n
 max_r: forall n m : nat, n <= m -> Nat.max n m = m
 min_r: forall n m : nat, m <= n -> Nat.min n m = m
-max_l: forall n m : nat, m <= n -> Nat.max n m = n
+min_l: forall n m : nat, n <= m -> Nat.min n m = n
 le_ind:
   forall (n : nat) (P : nat -> Prop),
   P n ->
   (forall m : nat, n <= m -> P m -> P (S m)) ->
   forall n0 : nat, n <= n0 -> P n0
+le_sind:
+  forall (n : nat) (P : nat -> SProp),
+  P n ->
+  (forall m : nat, n <= m -> P m -> P (S m)) ->
+  forall n0 : nat, n <= n0 -> P n0
 false: bool
 true: bool
+eq_true: bool -> Prop
 is_true: bool -> Prop
 negb: bool -> bool
-eq_true: bool -> Prop
-implb: bool -> bool -> bool
-orb: bool -> bool -> bool
 andb: bool -> bool -> bool
+orb: bool -> bool -> bool
+implb: bool -> bool -> bool
 xorb: bool -> bool -> bool
 Nat.even: nat -> bool
 Nat.odd: nat -> bool
 BoolSpec: Prop -> Prop -> bool -> Prop
-Nat.eqb: nat -> nat -> bool
-Nat.testbit: nat -> nat -> bool
 Nat.ltb: nat -> nat -> bool
+Nat.testbit: nat -> nat -> bool
+Nat.eqb: nat -> nat -> bool
 Nat.leb: nat -> nat -> bool
 Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat
-bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b
 bool_rec: forall P : bool -> Set, P true -> P false -> forall b : bool, P b
+eq_true_ind_r:
+  forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true
 eq_true_rec:
   forall P : bool -> Set, P true -> forall b : bool, eq_true b -> P b
-bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b
-eq_true_rect_r:
-  forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true
-eq_true_rec_r:
-  forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true
+bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b
 eq_true_rect:
   forall P : bool -> Type, P true -> forall b : bool, eq_true b -> P b
+eq_true_sind:
+  forall P : bool -> SProp, P true -> forall b : bool, eq_true b -> P b
+bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b
 eq_true_ind:
   forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b
-eq_true_ind_r:
-  forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true
+eq_true_rec_r:
+  forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true
+eq_true_rect_r:
+  forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true
+bool_sind:
+  forall P : bool -> SProp, P true -> P false -> forall b : bool, P b
 Byte.to_bits:
   Byte.byte ->
   bool * (bool * (bool * (bool * (bool * (bool * (bool * bool))))))
 Byte.of_bits:
   bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) ->
   Byte.byte
+andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true
 andb_true_intro:
   forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true
-andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true
+BoolSpec_sind:
+  forall (P Q : Prop) (P0 : bool -> SProp),
+  (P -> P0 true) ->
+  (Q -> P0 false) -> forall b : bool, BoolSpec P Q b -> P0 b
 BoolSpec_ind:
   forall (P Q : Prop) (P0 : bool -> Prop),
   (P -> P0 true) ->
diff --git a/test-suite/success/sprop.v b/test-suite/success/sprop.v
index 1e17d090c2..0e65211390 100644
--- a/test-suite/success/sprop.v
+++ b/test-suite/success/sprop.v
@@ -1,8 +1,12 @@
 (* -*- mode: coq; coq-prog-args: ("-allow-sprop") -*- *)
 
+Set Primitive Projections.
+Set Warnings "+non-primitive-record".
+
 Check SProp.
 
 Definition iUnit : SProp := forall A : SProp, A -> A.
+
 Definition itt : iUnit := fun A a => a.
 
 Definition iSquash (A:Type) : SProp
@@ -17,3 +21,122 @@ Proof. pose (fun A : SProp => A : Type). Abort.
 
 (* define evar as product *)
 Check (fun (f:(_:SProp)) => f _).
+
+Inductive sBox (A:SProp) : Prop
+  := sbox : A -> sBox A.
+
+Definition uBox := sBox iUnit.
+
+(* Primitive record with all fields in SProp has the eta property of SProp so must be SProp. *)
+Fail Record rBox (A:SProp) : Prop := rmkbox { runbox : A }.
+Section Opt.
+  Local Unset Primitive Projections.
+  Record rBox (A:SProp) : Prop := rmkbox { runbox : A }.
+End Opt.
+
+(* Check that defining as an emulated record worked *)
+Check runbox.
+
+(* Check that it doesn't have eta *)
+Fail Check (fun (A : SProp) (x : rBox A) => eq_refl : x = @rmkbox _ (@runbox _ x)).
+
+Inductive sEmpty : SProp := .
+
+Inductive sUnit : SProp := stt.
+
+Inductive BIG : SProp := foo | bar.
+
+Inductive Squash (A:Type) : SProp
+  := squash : A -> Squash A.
+
+Definition BIG_flip : BIG -> BIG.
+Proof.
+  intros [|]. exact bar. exact foo.
+Defined.
+
+Inductive pb : Prop := pt | pf.
+
+Definition pb_big : pb -> BIG.
+Proof.
+  intros [|]. exact foo. exact bar.
+Defined.
+
+Fail Definition big_pb (b:BIG) : pb :=
+  match b return pb with foo => pt | bar => pf end.
+
+Inductive which_pb : pb -> SProp :=
+| is_pt : which_pb pt
+| is_pf : which_pb pf.
+
+Fail Definition pb_which b (w:which_pb b) : bool
+  := match w with
+     | is_pt => true
+     | is_pf => false
+     end.
+
+(* Non primitive because no arguments, but maybe we should allow it for sprops? *)
+Fail Record UnitRecord : SProp := {}.
+
+Section Opt.
+  Local Unset Primitive Projections.
+  Record UnitRecord' : SProp := {}.
+End Opt.
+Fail Scheme Induction for UnitRecord' Sort Set.
+
+Record sProd (A B : SProp) : SProp := sPair { sFst : A; sSnd : B }.
+
+Scheme Induction for sProd Sort Set.
+
+Unset Primitive Projections.
+Record sProd' (A B : SProp) : SProp := sPair' { sFst' : A; sSnd' : B }.
+Set Primitive Projections.
+
+Fail Scheme Induction for sProd' Sort Set.
+
+Inductive Istrue : bool -> SProp := istrue : Istrue true.
+
+Definition Istrue_sym (b:bool) := if b then sUnit else sEmpty.
+Definition Istrue_to_sym b (i:Istrue b) : Istrue_sym b := match i with istrue => stt end.
+
+Record Truepack := truepack { trueval :> bool; trueprop : Istrue trueval }.
+
+Class emptyclass : SProp := emptyinstance : forall A:SProp, A.
+
+(** Sigma in SProp can be done through Squash and relevant sigma. *)
+Definition sSigma (A:SProp) (B:A -> SProp) : SProp
+  := Squash (@sigT (rBox A) (fun x => rBox (B (runbox _ x)))).
+
+Definition spair (A:SProp) (B:A->SProp) (x:A) (y:B x) : sSigma A B
+  := squash _ (existT _ (rmkbox _ x) (rmkbox _ y)).
+
+Definition spr1 (A:SProp) (B:A->SProp) (p:sSigma A B) : A
+  := let 'squash _ (existT _ x y) := p in runbox _ x.
+
+Definition spr2 (A:SProp) (B:A->SProp) (p:sSigma A B) : B (spr1 A B p)
+  := let 'squash _ (existT _ x y) := p return B (spr1 A B p) in runbox _ y.
+(* it's SProp so it computes properly *)
+
+(** Fixpoints on SProp values are only allowed to produce SProp results *)
+Inductive sAcc (x:nat) : SProp := sAcc_in : (forall y, y < x -> sAcc y) -> sAcc x.
+
+Definition sAcc_inv x (s:sAcc x) : forall y, y < x -> sAcc y.
+Proof.
+  destruct s as [H]. exact H.
+Defined.
+
+Section sFix_fail.
+  Variable P : nat -> Type.
+  Variable F : forall x:nat, (forall y:nat, y < x -> P y) -> P x.
+
+  Fail Fixpoint sFix (x:nat) (a:sAcc x) {struct a} : P x :=
+    F x (fun (y:nat) (h: y < x) => sFix y (sAcc_inv x a y h)).
+End sFix_fail.
+
+Section sFix.
+  Variable P : nat -> SProp.
+  Variable F : forall x:nat, (forall y:nat, y < x -> P y) -> P x.
+
+  Fixpoint sFix (x:nat) (a:sAcc x) {struct a} : P x :=
+    F x (fun (y:nat) (h: y < x) => sFix y (sAcc_inv x a y h)).
+
+End sFix.