(* * Copyright (c) 2009 Robert Dockins and Aquinas Hobor. * *)
(* Coq development: using indirection theory to model types in l-calculus *)
(* lam_ref_type_defs.v: the definition of the type system; this is the main event. *)
Require Export lam_ref_type_prelim.
Open Scope pred.
(* From introduction; this is the judgment psi |- v : tau *)
Definition forces (psi : mtype) (v : value) (tau : pred world) :=
tau (psi, v).
(* Section 4.1, equation 17 *)
Program Definition ty_nat : pred world :=
fun w => match w with (k, v) =>
exists n, v = v_Nat n
end.
Next Obligation.
destruct a; destruct a'.
replace v0 with v; auto.
assert (necR (m,v) (m0,v0)).
apply rt_step; auto.
rewrite value_knot_necR in H1.
intuition.
Qed.
Program Definition type_at (l:addr) (tau:pred world) : pred world :=
fun w:world =>
let (n,psi) := unsquash (fst w) in
match psi l with
| None => False
| Some p => approx_eq n p tau
end.
Next Obligation.
unfold age, age1 in H.
destruct a; destruct a'.
simpl in *.
rewrite knot_age1 in H.
case_eq (unsquash m); intros; rewrite H1 in H, H0.
destruct n; try discriminate.
inv H.
rewrite unsquash_squash.
simpl.
case_eq (f l); simpl; intros; rewrite H in H0.
unfold approx_eq in *.
unfold fidentity_fmap.
change (approx n (approx n p)) with
((approx n oo approx n) p).
rewrite <- (approx_approx1 0).
rewrite (approx_approx1 1).
unfold compose; simpl.
rewrite H0; auto.
auto.
Qed.
Program Definition just (v:value) : pred world :=
fun w => snd w = v.
Next Obligation.
destruct a; destruct a'; simpl in *.
hnf in H; simpl in H.
rewrite knot_age1 in H.
case_eq (unsquash m); intros; rewrite H1 in H.
destruct n; inv H; auto.
Qed.
Program Definition with_val (v:value) (p:pred world) : pred world :=
fun w => p (fst w,v).
Next Obligation.
apply pred_hereditary with (fst a,v).
unfold age, age1 in *; simpl in *.
rewrite knot_age1 in *.
destruct a; destruct a'; simpl in *.
case_eq (unsquash m); intros; rewrite H1 in H; auto.
destruct n; inv H; auto.
auto.
Qed.
Definition ty_ref (tau: pred world) : pred world :=
EX a:addr, just (v_Loc a) && type_at a tau.
(* Section 5.1, equation 28 *)
Program Definition mtype_valid (m : mem) : pred world :=
fun w =>
match w with (k, v) =>
let (n,phi) := unsquash k in
forall (a : addr),
match phi a with
| None => fst m <= a
| Some tau => fst m > a /\ forces k (deref m a) (%|>tau)
end
end.
Next Obligation.
unfold age, age1 in H.
simpl in H.
rewrite knot_age1 in H.
destruct a; destruct a'.
simpl in *.
case_eq (unsquash m0); intros; rewrite H1 in H.
destruct n; try discriminate.
inv H.
rewrite H1 in H0.
rewrite unsquash_squash; simpl; intros.
spec H0 a.
case_eq (f a); simpl; intros.
rewrite H in H0.
intuition.
unfold fidentity_fmap. red.
rewrite approx_spec. split; auto.
apply lt_le_trans with (level (fst a')).
apply laterR_level in H4. auto.
destruct a'. simpl.
hnf in H0.
destruct H0.  hnf in H0.
rewrite unsquash_squash in H0.
simpl; rewrite knot_level.
case_eq (unsquash m1); intros; rewrite H6 in H0.
destruct H0; subst.
simpl; auto.
eapply pred_nec_hereditary.
apply Rt_Rft; auto.  apply H4.
assert ((%|> p) (m0,deref m a)); auto.
rewrite later_commute in H5.
eapply H5.
hnf; apply t_step.
unfold age, age1; simpl.
rewrite knot_age1.
rewrite H1; auto.
auto.
rewrite H in H0. auto.
Qed.
Definition expr_typeF (tau:pred world) (F: expr -> pred world) (e : expr) : pred world :=
%ALL m:mem, mtype_valid m -->
(ALL m':mem, ALL e':expr, !!(step (m,e) (m',e')) -->
|>(predicates_hered.diamond contractsM (mtype_valid m' && F e'))) &&
(!!(stopped m e) --> EX H:isValue e,
with_val (exp_to_val e H) (%tau)).
Definition expr_type e tau := HORec (expr_typeF tau) e.
Definition ty_lam (tau1 tau2 : pred world) : pred world :=
EX e:expr, EX H:closed' 1 e, just (v_Lam e H) &&
|>%(ALL v':value, with_val v' (%tau1) --> expr_type (subst 0 v' e) tau2).
Definition etype : Type := list (pred world).
Fixpoint etype_valid (e : env) (G : etype) : pred world :=
match (e,G) with
| (v :: es, tau :: Gs) => with_val v (%tau) && etype_valid es Gs
| (nil, nil) => TT
| _ => FF
end.
(* Not in paper, but should add.  Taken from VMM. *)
Definition Typ (G : etype) (exp : expr) (tau : pred world) : Prop :=
closed' (length G) exp  /\
forall env, etype_valid env G |-- expr_type (subst_env env exp) tau.

Lemma subp_type_at : forall G P Q l,
G |-- |>(P <=> Q) ->
G |-- type_at l P >=> type_at l Q.