(************************************************************************)
(*         *      The Rocq Prover / The Rocq Development Team           *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(** Tactics related to (dependent) equality and proof irrelevance. *)
Require Export JMeq.
Ltac is_ground_goal :=
match goal with
|- ?T => is_ground T
end.
(** Try to find a contradiction. *)
#[global]
Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso.
(** We will use the [block] definition to separate the goal from the equalities generated by the tactic. *)
Definition block {A : Type} (a : A) := a.
Ltac block_goal := match goal with [ |- ?T ] => change (block T) end.
Ltac unblock_goal := unfold block in *.
(** Notation for heterogeneous equality. *)
#[deprecated(since="8.17")]
Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity).
(** Do something on an heterogeneous equality appearing in the context. *)
Ltac on_JMeq tac :=
match goal with
| [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H
end.
(** Try to apply [JMeq_eq] to get back a regular equality when the two types are equal. *)
Ltac simpl_one_JMeq :=
on_JMeq ltac:(fun H => apply JMeq_eq in H).
(** Repeat it for every possible hypothesis. *)
Ltac simpl_JMeq := repeat simpl_one_JMeq.
(** Just simplify an h.eq. without clearing it. *)
Ltac simpl_one_dep_JMeq :=
on_JMeq
ltac:(fun H => let H' := fresh "H" in
assert (H' := JMeq_eq H)).
(** Simplify dependent equality using sigmas to equality of the second projections if possible. Uses UIP. *)
Ltac simpl_existT :=
match goal with
[ H : existT _ ?x _ = existT _ ?x _ |- _ ] =>
let Hi := fresh H in assert(Hi:=inj_pairT2 _ _ _ _ _ H) ; clear H
end.
Ltac simpl_existTs := repeat simpl_existT.
(** Tries to eliminate a call to [eq_rect] (the substitution principle) by any means available. *)
Ltac elim_eq_rect :=
match goal with
| [ |- ?t ] =>
match t with
| context [ @eq_rect _ _ _ _ _ ?p ] =>
let P := fresh "P" in
set (P := p); simpl in P ;
((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
| context [ @eq_rect _ _ _ _ _ ?p _ ] =>
let P := fresh "P" in
set (P := p); simpl in P ;
((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
end
end.
(** Rewrite using uniqueness of identity proofs [H = eq_refl]. *)
Ltac simpl_uip :=
match goal with
[ H : ?X = ?X |- _ ] => rewrite (UIP_refl _ _ H) in *; clear H
end.
(** Simplify equalities appearing in the context and goal. *)
Ltac simpl_eq := simpl ; unfold eq_rec_r, eq_rec ; repeat (elim_eq_rect ; simpl) ; repeat (simpl_uip ; simpl).
(** Try to abstract a proof of equality, if no proof of the same equality is present in the context. *)
Ltac abstract_eq_hyp H' p :=
let ty := type of p in
let tyred := eval simpl in ty in
match tyred with
?X = ?Y =>
match goal with
| [ H : X = Y |- _ ] => fail 1
| _ => set (H':=p) ; try (change p with H') ; clearbody H' ; simpl in H'
end
end.
(** Apply the tactic tac to proofs of equality appearing as coercion arguments. Just redefine this tactic (using [Ltac on_coerce_proof tac ::=]) to handle custom coercion operators. *)
Ltac on_coerce_proof tac T :=
match T with
| context [ eq_rect _ _ _ _ ?p ] => tac p
end.
Ltac on_coerce_proof_gl tac :=
match goal with
[ |- ?T ] => on_coerce_proof tac T
end.
(** Abstract proofs of equalities of coercions. *)
Ltac abstract_eq_proof := on_coerce_proof_gl ltac:(fun p => let H := fresh "eqH" in abstract_eq_hyp H p).
Ltac abstract_eq_proofs := repeat abstract_eq_proof.
(** Factorize proofs, by using proof irrelevance so that two proofs of the same equality in the goal become convertible. *)
Ltac pi_eq_proof_hyp p :=
let ty := type of p in
let tyred := eval simpl in ty in
match tyred with
?X = ?Y =>
match goal with
| [ H : X = Y |- _ ] =>
match p with
| H => fail 2
| _ => rewrite (UIP _ X Y p H)
end
| _ => fail " No hypothesis with same type "
end
end.
(** Factorize proofs of equality appearing as coercion arguments. *)
Ltac pi_eq_proof := on_coerce_proof_gl pi_eq_proof_hyp.
Ltac pi_eq_proofs := repeat pi_eq_proof.
(** The two preceding tactics in sequence. *)
Ltac clear_eq_proofs :=
abstract_eq_proofs ; pi_eq_proofs.
Global Hint Rewrite <- eq_rect_eq : refl_id.
(** The [refl_id] database should be populated with lemmas of the form [coerce_* t eq_refl = t]. *)

Lemma JMeq_eq_refl {A} (x : A) : JMeq_eq (@JMeq_refl _ x) = eq_refl.