mpri-funcprog-project/coq/MetalSyntax.v
2017-10-05 17:57:33 +02:00

432 lines
10 KiB
Coq

Require Import List.
Require Import MyList.
Require Import MyTactics.
Require Export Autosubst.Autosubst.
Require Export AutosubstExtra.
Require Export Autosubst_EOS.
Require Export Autosubst_FreeVars.
(* -------------------------------------------------------------------------- *)
(* Metal is a lambda-calculus where every lambda-abstractions must be closed.
It is equipped with pairs and projections. It is intended to serve as the
target of closure conversion. *)
(* -------------------------------------------------------------------------- *)
(* Syntax. *)
Inductive metal :=
| MVar : var -> metal
| MLam : {bind metal} -> metal
| MApp : metal -> metal -> metal
| MLet : metal -> {bind metal} -> metal
| MPair : metal -> metal -> metal
| MPi : nat -> metal -> metal
.
Instance Ids_metal : Ids metal. derive. Defined.
Instance Rename_metal : Rename metal. derive. Defined.
Instance Subst_metal : Subst metal. derive. Defined.
Instance SubstLemmas_metal : SubstLemmas metal. derive. Qed.
Instance IdsLemmas_metal : IdsLemmas metal.
Proof. econstructor. intros. injections. eauto. Qed.
(* -------------------------------------------------------------------------- *)
(* We equip the calculus with pairs, instead of general tuples, because
this makes life in Coq simpler -- we would otherwise have an occurrence
of [list metal] in the definition of [metal], and would need to ask for
a custom induction scheme. *)
(* Instead, we simulate tuples using nested pairs. This would of course be
inefficient in real life, but fur our purposes, should be fine. *)
Fixpoint MTuple ts :=
match ts with
| nil =>
(* A dummy value serves as the tail. *)
MLam (MVar 0)
| t :: ts =>
MPair t (MTuple ts)
end.
Fixpoint MProj i t :=
match i with
| 0 =>
(* Take the left pair component. *)
MPi 0 t
| S i =>
(* Take the right pair component and continue. *)
MProj i (MPi 1 t)
end.
Definition MLetPair t u :=
MLet (* x_0 = *) (MPi 0 t) (
MLet (* x_1 = *) (MPi 1 (lift 1 t))
u
).
(* -------------------------------------------------------------------------- *)
(* [MMultiLet 0 ts u] is a sequence of [MLet] bindings. [n] variables, where
[n] is [length ts], are bound to the terms [ts] in the term [u]. The
recursive structure of the definition is such that the *last* term in the
list [ts] is bound *last*, hence is referred to as variable 0 in [u]. *)
Fixpoint MMultiLet i ts u :=
match ts with
| nil =>
u
| t :: ts =>
MLet (lift i t) (MMultiLet (i + 1) ts u)
end.
(* The auxiliary parameter [i] in [MMultiLet i ts u] is required for the
recursive definition to go through, but, as far as the end user is
concerned, is not very useful. It can be eliminated as follows. *)
Lemma MMultiLet_ij:
forall ts delta i j u,
i + delta = j ->
MMultiLet j ts u = MMultiLet i (map (fun t => lift delta t) ts) u.
Proof.
induction ts; intros; simpl; eauto.
f_equal.
{ asimpl. congruence. }
{ erewrite IHts. eauto. omega. }
Qed.
Lemma MMultiLet_i0:
forall i ts u,
MMultiLet i ts u = MMultiLet 0 (map (fun t => lift i t) ts) u.
Proof.
eauto using MMultiLet_ij with omega.
Qed.
(* -------------------------------------------------------------------------- *)
(* [MVars n] is the list [MVar 0, ..., MVar (n-1)]. *)
Definition MVars (n : nat) : list metal :=
map MVar (nats n).
(* -------------------------------------------------------------------------- *)
(* [MProjs n t] is the list [MProj n t, ..., MProj 1 t]. *)
Definition MProjs (n : nat) (t : metal) :=
map (fun i => MProj (i + 1) t) (rev_nats n).
(* This list has length [n]. *)
Lemma length_MProjs:
forall n t,
length (MProjs n t) = n.
Proof.
unfold MProjs. intros. rewrite map_length, length_rev_nats. eauto.
Qed.
Hint Rewrite length_MProjs : length.
(* -------------------------------------------------------------------------- *)
(* Substitution (boilerplate lemmas). *)
Lemma subst_MVar:
forall x sigma,
(MVar x).[sigma] = sigma x.
Proof.
intros. autosubst.
Qed.
Lemma subst_MLam:
forall t sigma,
(MLam t).[sigma] = MLam t.[up sigma].
Proof.
intros. autosubst.
Qed.
Lemma subst_MApp:
forall t1 t2 sigma,
(MApp t1 t2).[sigma] = MApp t1.[sigma] t2.[sigma].
Proof.
intros. autosubst.
Qed.
Lemma subst_MLet:
forall t1 t2 sigma,
(MLet t1 t2).[sigma] = MLet t1.[sigma] t2.[up sigma].
Proof.
intros. autosubst.
Qed.
Lemma subst_MPair:
forall t1 t2 sigma,
(MPair t1 t2).[sigma] = MPair t1.[sigma] t2.[sigma].
Proof.
intros. autosubst.
Qed.
Lemma subst_MPi:
forall i t sigma,
(MPi i t).[sigma] = MPi i t.[sigma].
Proof.
intros. autosubst.
Qed.
Lemma subst_MTuple:
forall ts sigma,
(MTuple ts).[sigma] = MTuple (map (subst sigma) ts).
Proof.
induction ts; intros; asimpl; [ | rewrite IHts ]; reflexivity.
Qed.
Lemma subst_MProj:
forall n t sigma,
(MProj n t).[sigma] = MProj n t.[sigma].
Proof.
induction n; intros; asimpl; [ | rewrite IHn ]; autosubst.
Qed.
Lemma subst_MLetPair:
forall t u sigma,
(MLetPair t u).[sigma] = MLetPair t.[sigma] u.[upn 2 sigma].
Proof.
unfold MLetPair. intros. autosubst.
Qed.
Lemma subst_MMultiLet:
forall ts i u sigma,
(MMultiLet i ts u).[upn i sigma] =
MMultiLet i (map (subst sigma) ts) u.[upn (length ts) (upn i sigma)].
Proof.
induction ts; intros; asimpl; f_equal.
{ erewrite plus_upn by tc. eauto. }
{ rewrite IHts.
repeat erewrite upn_upn by tc.
do 3 f_equal. omega. }
Qed.
Lemma subst_MMultiLet_0:
forall ts u sigma,
(MMultiLet 0 ts u).[sigma] =
MMultiLet 0 (map (subst sigma) ts) u.[upn (length ts) sigma].
Proof.
intros.
change sigma with (upn 0 sigma) at 1.
eapply subst_MMultiLet.
Qed.
Lemma subst_MVars:
forall n sigma,
map (subst sigma) (MVars n) = map sigma (nats n).
Proof.
intros. unfold MVars. rewrite map_map. reflexivity.
Qed.
Lemma subst_MProjs:
forall n t sigma,
map (subst sigma) (MProjs n t) = MProjs n t.[sigma].
Proof.
unfold MProjs. induction n; intros; simpl; eauto.
rewrite subst_MProj, IHn. eauto.
Qed.
Hint Rewrite
subst_MVar subst_MLam subst_MApp subst_MLet subst_MPair subst_MPi
subst_MTuple subst_MProj subst_MLetPair
subst_MMultiLet subst_MMultiLet_0
subst_MVars subst_MProjs
: subst.
(* -------------------------------------------------------------------------- *)
(* Free variables (boilerplate lemmas). *)
Lemma fv_MVar:
forall x k,
fv k (MVar x) <-> x < k.
Proof.
eauto using fv_ids_eq.
Qed.
Ltac prove_fv :=
unfold fv; intros; asimpl;
split; intros; unpack; [ injections | f_equal ]; eauto.
Lemma fv_MLam:
forall t k,
fv k (MLam t) <-> fv (k + 1) t.
Proof.
prove_fv.
Qed.
Lemma fv_MApp:
forall t1 t2 k,
fv k (MApp t1 t2) <-> fv k t1 /\ fv k t2.
Proof.
prove_fv.
Qed.
Lemma fv_MLet:
forall t1 t2 k,
fv k (MLet t1 t2) <-> fv k t1 /\ fv (k + 1) t2.
Proof.
prove_fv.
Qed.
Lemma fv_MPair:
forall t1 t2 k,
fv k (MPair t1 t2) <-> fv k t1 /\ fv k t2.
Proof.
prove_fv.
Qed.
Lemma fv_MPi:
forall i t k,
fv k (MPi i t) <-> fv k t.
Proof.
prove_fv.
Qed.
Hint Rewrite fv_MVar fv_MLam fv_MApp fv_MLet fv_MPair fv_MPi : fv.
Lemma fv_MTuple:
forall k ts,
fv k (MTuple ts) <-> Forall (fv k) ts.
Proof.
induction ts; simpl; intros; fv; split; intros; unpack.
{ econstructor. }
{ omega. }
{ rewrite IHts in *. econstructor; eauto. }
{ rewrite IHts in *. pick Forall invert. eauto. }
Qed.
Lemma fv_MProj:
forall k n t,
fv k (MProj n t) <-> fv k t.
Proof.
induction n; intros; simpl; [ | rewrite IHn ]; fv; tauto.
Qed.
Lemma fv_MLetPair:
forall k t u,
fv k (MLetPair t u) <-> fv k t /\ fv (k + 2) u.
Proof.
intros. unfold MLetPair. fv; tc.
replace (k + 1 + 1) with (k + 2) by omega.
tauto.
Qed.
Local Lemma MLet_inj:
forall t1 u1 t2 u2,
MLet t1 u1 = MLet t2 u2 <-> t1 = t2 /\ u1 = u2.
Proof.
split; intros; injections; unpack; subst; eauto.
Qed.
Local Lemma cons_cons_eq:
forall {A} (x1 x2 : A) xs1 xs2,
x1 :: xs1 = x2 :: xs2 <->
x1 = x2 /\ xs1 = xs2.
Proof.
split; intros; injections; unpack; subst; eauto.
Qed.
Local Lemma MMultiLet_inj:
forall ts1 u1 ts2 u2 i,
length ts1 = length ts2 ->
MMultiLet i ts1 u1 = MMultiLet i ts2 u2 <->
ts1 = ts2 /\ u1 = u2.
Proof.
induction ts1; destruct ts2; intros; simpl;
try solve [ false; simpl in *; omega ].
{ tauto. }
{ rewrite MLet_inj.
rewrite lift_injn_eq.
rewrite IHts1 by (simpl in *; omega).
rewrite cons_cons_eq.
tauto. }
Qed.
Local Lemma map_inj:
forall {A} (f : A -> A) xs,
map f xs = xs <->
Forall (fun x => f x = x) xs.
Proof.
induction xs; simpl; intros; split; intros; eauto using Forall;
injections.
{ econstructor; tauto. }
{ pick Forall invert. f_equal; tauto. }
Qed.
Lemma fv_MMultiLet_0:
forall ts u k,
fv k (MMultiLet 0 ts u) <->
Forall (fv k) ts /\ fv (k + length ts) u.
Proof.
intros. unfold fv.
autorewrite with subst.
rewrite MMultiLet_inj by eauto using map_length.
rewrite upn_upn, Nat.add_comm.
rewrite map_inj.
tauto.
Qed.
Lemma fv_MVars:
forall n,
Forall (fv n) (MVars n) <->
True.
Proof.
split; [ eauto | intros _ ].
unfold MVars, nats.
eapply Forall_map.
eapply Forall_seq; intros.
fv. omega.
Qed.
Lemma fv_MProjs:
forall k n t,
fv k t -> (* not an equivalence, as [k] could be zero *)
Forall (fv k) (MProjs n t).
Proof.
unfold MProjs. induction n; simpl; intros;
econstructor; [ rewrite fv_MProj |]; eauto.
Qed.
Hint Rewrite
fv_MTuple fv_MProj fv_MLetPair fv_MMultiLet_0
fv_MVars
(* not fv_MProjs *)
: fv.
(* -------------------------------------------------------------------------- *)
(* The following lemma is analogous to [fv_unaffected_regular], except it does
not have a regularity hypothesis, which makes it more pleasant to use. It is
proved by induction on terms, which is why we are unable to prove it in a
generic setting. *)
Lemma fv_unaffected:
forall t k sigma,
fv k t ->
t.[upn k sigma] = t.
Proof.
induction t; intros; fv; unpack; asimpl; repeat rewrite Nat.add_1_r in *;
try solve [ eauto using upn_k_sigma_x with typeclass_instances
| f_equal; eauto ].
Qed.
(* A corollary. *)
Lemma closed_unaffected:
forall t sigma,
closed t ->
t.[sigma] = t.
Proof.
unfold closed. intros.
rewrite <- (upn0 sigma).
eauto using fv_unaffected.
Qed.