Commit a4f0f4b0 authored by Ralf Jung's avatar Ralf Jung

Split prettification from proof mode reduction

pm_reduce just reduces away proof mode terms using cbv; pm_prettify just prettifies user-visible connectors using cbn.
Most uses of pm_default are converted to default to keep the desired reduction behavior.
parent 34f64c8d
...@@ -197,7 +197,7 @@ Tactic failure: iFrame: cannot frame Q. ...@@ -197,7 +197,7 @@ Tactic failure: iFrame: cannot frame Q.
============================ ============================
"HPQ" : mP -∗? Q "HPQ" : mP -∗? Q
"HQR" : Q -∗ R "HQR" : Q -∗ R
"HP" : pm_default emp mP "HP" : default emp mP
--------------------------------------∗ --------------------------------------∗
R R
...@@ -207,9 +207,25 @@ Tactic failure: iFrame: cannot frame Q. ...@@ -207,9 +207,25 @@ Tactic failure: iFrame: cannot frame Q.
mP : option PROP mP : option PROP
Q, R : PROP Q, R : PROP
============================ ============================
"HP" : pm_default emp mP "HP" : default emp mP
--------------------------------------∗ --------------------------------------∗
pm_default emp mP default emp mP
"elim_mod_accessor"
: string
1 subgoal
PROP : sbi
BiFUpd0 : BiFUpd PROP
X : Type
E1, E2 : coPset.coPset
α : X → PROP
β : X → PROP
γ : X → option PROP
============================
"Hacc" : ∃ x : X, α x ∗ (β x ={E2,E1}=∗ default emp (γ x))
--------------------------------------∗
|={E2,E1}=> True
1 subgoal 1 subgoal
......
...@@ -544,6 +544,12 @@ Section wandM. ...@@ -544,6 +544,12 @@ Section wandM.
Qed. Qed.
End wandM. End wandM.
Definition big_op_singleton_def (P : nat PROP) (l : list nat) :=
([ list] n l, P n)%I.
Lemma test_iApply_big_op_singleton (P : nat PROP) :
P 1 - big_op_singleton_def P [1].
Proof. iIntros "?". iApply big_sepL_singleton. iAssumption. Qed.
End tests. End tests.
(** Test specifically if certain things print correctly. *) (** Test specifically if certain things print correctly. *)
...@@ -551,6 +557,11 @@ Section printing_tests. ...@@ -551,6 +557,11 @@ Section printing_tests.
Context {PROP : sbi} `{!BiFUpd PROP}. Context {PROP : sbi} `{!BiFUpd PROP}.
Implicit Types P Q R : PROP. Implicit Types P Q R : PROP.
Check "elim_mod_accessor".
Lemma elim_mod_accessor {X : Type} E1 E2 α (β : X PROP) γ :
accessor (fupd E1 E2) (fupd E2 E1) α β γ - |={E1}=> True.
Proof. iIntros ">Hacc". Show. Abort.
(* Test line breaking of long assumptions. *) (* Test line breaking of long assumptions. *)
Section linebreaks. Section linebreaks.
Lemma print_long_line (P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P : PROP) : Lemma print_long_line (P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P_P : PROP) :
......
...@@ -385,7 +385,7 @@ Proof. ...@@ -385,7 +385,7 @@ Proof.
Qed. Qed.
Global Instance into_wand_wandM p q mP' P Q : Global Instance into_wand_wandM p q mP' P Q :
FromAssumption q P (pm_default emp%I mP') IntoWand p q (mP' -? Q) P Q. FromAssumption q P (default emp%I mP') IntoWand p q (mP' -? Q) P Q.
Proof. rewrite /IntoWand wandM_sound. exact: into_wand_wand. Qed. Proof. rewrite /IntoWand wandM_sound. exact: into_wand_wand. Qed.
Global Instance into_wand_and_l p q R1 R2 P' Q' : Global Instance into_wand_and_l p q R1 R2 P' Q' :
...@@ -510,7 +510,7 @@ Qed. ...@@ -510,7 +510,7 @@ Qed.
Global Instance from_wand_wand P1 P2 : FromWand (P1 - P2) P1 P2. Global Instance from_wand_wand P1 P2 : FromWand (P1 - P2) P1 P2.
Proof. by rewrite /FromWand. Qed. Proof. by rewrite /FromWand. Qed.
Global Instance from_wand_wandM mP1 P2 : Global Instance from_wand_wandM mP1 P2 :
FromWand (mP1 -? P2) (pm_default emp mP1)%I P2. FromWand (mP1 -? P2) (default emp mP1)%I P2.
Proof. by rewrite /FromWand wandM_sound. Qed. Proof. by rewrite /FromWand wandM_sound. Qed.
Global Instance from_wand_embed `{BiEmbed PROP PROP'} P Q1 Q2 : Global Instance from_wand_embed `{BiEmbed PROP PROP'} P Q1 Q2 :
FromWand P Q1 Q2 FromWand P Q1 Q2. FromWand P Q1 Q2 FromWand P Q1 Q2.
...@@ -1079,6 +1079,9 @@ Proof. ...@@ -1079,6 +1079,9 @@ Proof.
- iApply (Hacc with "Hinv Hin"). done. - iApply (Hacc with "Hinv Hin"). done.
Qed. Qed.
(* This uses [pm_default] because, after inference, all accessors will have
[None] or [Some _] there, so we want to reduce the combinator before showing the
goal to the user. *)
Global Instance elim_inv_acc_with_close {X : Type} Global Instance elim_inv_acc_with_close {X : Type}
φ1 φ2 Pinv Pin φ1 φ2 Pinv Pin
M1 M2 α β mγ Q Q' : M1 M2 α β mγ Q Q' :
......
...@@ -526,7 +526,7 @@ Hint Mode IntoInv + ! - : typeclass_instances. ...@@ -526,7 +526,7 @@ Hint Mode IntoInv + ! - : typeclass_instances.
instances to recognize the [emp] case and make it look nicer. *) instances to recognize the [emp] case and make it look nicer. *)
Definition accessor {PROP : bi} {X : Type} (M1 M2 : PROP PROP) Definition accessor {PROP : bi} {X : Type} (M1 M2 : PROP PROP)
(α β : X PROP) (mγ : X option PROP) : PROP := (α β : X PROP) (mγ : X option PROP) : PROP :=
M1 ( x, α x (β x - M2 (pm_default emp (mγ x))))%I. M1 ( x, α x (β x - M2 (default emp (mγ x))))%I.
(* Typeclass for assertions around which accessors can be elliminated. (* Typeclass for assertions around which accessors can be elliminated.
Inputs: [Q], [E1], [E2], [α], [β], [γ] Inputs: [Q], [E1], [E2], [α], [β], [γ]
...@@ -582,7 +582,7 @@ Hint Mode IntoAcc + - ! - - - - - - - : typeclass_instances. ...@@ -582,7 +582,7 @@ Hint Mode IntoAcc + - ! - - - - - - - : typeclass_instances.
Class ElimInv {PROP : bi} {X : Type} (φ : Prop) Class ElimInv {PROP : bi} {X : Type} (φ : Prop)
(Pinv Pin : PROP) (Pout : X PROP) (mPclose : option (X PROP)) (Pinv Pin : PROP) (Pout : X PROP) (mPclose : option (X PROP))
(Q : PROP) (Q' : X PROP) := (Q : PROP) (Q' : X PROP) :=
elim_inv : φ Pinv Pin ( x, Pout x (pm_default (λ _, emp) mPclose) x - Q' x) Q. elim_inv : φ Pinv Pin ( x, Pout x (default (λ _, emp) mPclose) x - Q' x) Q.
Arguments ElimInv {_} {_} _ _%I _%I _%I _%I _%I _%I : simpl never. Arguments ElimInv {_} {_} _ _%I _%I _%I _%I _%I _%I : simpl never.
Arguments elim_inv {_} {_} _ _%I _%I _%I _%I _%I _%I {_}. Arguments elim_inv {_} {_} _ _%I _%I _%I _%I _%I _%I {_}.
Hint Mode ElimInv + - - ! - - ! ! - : typeclass_instances. Hint Mode ElimInv + - - ! - - ! ! - : typeclass_instances.
......
...@@ -1108,7 +1108,7 @@ Tactic Notation "iDestructHyp" constr(H) "as" constr(pat) := ...@@ -1108,7 +1108,7 @@ Tactic Notation "iDestructHyp" constr(H) "as" constr(pat) :=
lazymatch pats with lazymatch pats with
| [] => | [] =>
lazymatch found with lazymatch found with
| true => idtac | true => pm_prettify (* post-tactic prettification *)
| false => fail "iDestruct:" pat "should contain exactly one proper introduction pattern" | false => fail "iDestruct:" pat "should contain exactly one proper introduction pattern"
end end
| ISimpl :: ?pats => simpl; find_pat found pats | ISimpl :: ?pats => simpl; find_pat found pats
......
...@@ -11,13 +11,13 @@ Declare Reduction pm_cbv := cbv [ ...@@ -11,13 +11,13 @@ Declare Reduction pm_cbv := cbv [
envs_simple_replace envs_replace envs_split envs_simple_replace envs_replace envs_split
envs_clear_spatial envs_clear_persistent envs_incr_counter envs_clear_spatial envs_clear_persistent envs_incr_counter
envs_split_go envs_split prop_of_env envs_split_go envs_split prop_of_env
(* PM option combinators *)
pm_option_bind pm_from_option pm_option_fun
]. ].
(* Some things should only be unfolded according to cbn rules, when (* Some things should only be unfolded according to cbn rules, when
certain arguments are constructors. This is because they can appear in certain arguments are constructors. This is because they can appear in
the user side of proofs as well. *) the user side of proofs as well. *)
Declare Reduction pm_cbn := cbn [ Declare Reduction pm_cbn := cbn [
(* PM option combinators *)
pm_option_bind pm_from_option pm_option_fun
(* telescope combinators *) (* telescope combinators *)
tele_fold tele_bind tele_app tele_fold tele_bind tele_app
(* BI connectives *) (* BI connectives *)
...@@ -25,15 +25,17 @@ Declare Reduction pm_cbn := cbn [ ...@@ -25,15 +25,17 @@ Declare Reduction pm_cbn := cbn [
bi_wandM sbi_laterN bi_wandM sbi_laterN
bi_tforall bi_texist bi_tforall bi_texist
]. ].
(** Called by all tactics to perform computation to lookup items in the
context. We avoid reducing anything user-visible here to make sure we
do not reduce e.g. before unification happens in [iApply].*)
Ltac pm_eval t := Ltac pm_eval t :=
let u := eval pm_cbv in t in eval pm_cbv in t.
let v := eval pm_cbn in u in
v.
Ltac pm_reduce := Ltac pm_reduce :=
match goal with |- ?u => let v := pm_eval u in change v end. match goal with |- ?u => let v := pm_eval u in change v end.
Ltac pm_reflexivity := pm_reduce; exact eq_refl. Ltac pm_reflexivity := pm_reduce; exact eq_refl.
(** Called e.g. by iApply for redexes that are created by instantiation. (** Called by many tactics for redexes that are created by instantiation.
This cannot create any envs redexes so we just to the cbn part. *) This cannot create any envs redexes so we just do the cbn part. *)
Ltac pm_prettify := Ltac pm_prettify :=
match goal with |- ?u => let v := eval pm_cbn in u in change v end. match goal with |- ?u => let v := eval pm_cbn in u in change v end.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment