(** * Software Foundations, Formally
      Benjamin C. Pierce
      Version of 12/5/2007
*)

(* Wei: The typing notation "CT >> Gamma |- t ~ T" defined here
           conflicts with what we've seen since lec17 *)
Require Export lec13_sol.

(* Wei: Pull in necessary definitions *)
Definition alist (X : Set) := list (nat * X).
Fixpoint lookup (X : Set) (k : nat) (l : alist X) {struct l} : option X :=
  match l with
  | nil => None _
  | (j',a') :: l' =>
      if eqnat k j' then Some _ a' else lookup _ k l'
  end.
Definition binds (X:Set) (k:nat) (v:X) (l:alist X) :=
  lookup X k l = Some _ v.

(* Look over today's lecture slides and read TAPL Chapter 19 carefully
   before digging into the Coq formalization that follows. *)

(* This material was formalized by Leonid Spesivtsev based on an
   earlier formalization by Stephanie Weirich.

   It is just definitions and statements of properties at the
   moment -- no proofs.*)

Module FeatherweightJava.

(* ---------------------------------------------------------------------- *)
(* Syntax *)

(* Declare some synonyms for [nat] to make the definition of terms easier to follow. *)
Definition varName    :Set := nat.
Definition fieldName  :Set := nat.
Definition methodName :Set := nat.
Definition className  :Set := nat.

(* Types are just class names in FJ.  (In full Java there are also a
   handful of other types like [int] and [bool].  We ignore these.)
   So we don't need an inductive definition of the set of types. *)

(* Syntax of terms *)
Inductive tm : Set := 
  | tm_var : varName -> tm                        (* variable *)
  | tm_field : tm -> fieldName -> tm              (* field access *)
  | tm_invoke : tm -> methodName -> list tm -> tm (* method invocation *)
  | tm_new : className -> list tm -> tm           (* object creation *)
  | tm_cast : className -> tm -> tm.              (* cast *)

Hint Constructors tm.
Tactic Notation "tm_cases" tactic(first) tactic(c) :=
  first;
  [ c "tm_var" | c "tm_field" | c "tm_invoke" | c "tm_new" | c "tm_cast" ].

Definition this := zero.

(* Syntax of values.  (Intuitively: A value is a [new] expression
   where all the constructor arguments are also values.) *)
Inductive value : tm -> Prop :=
  | v_new : forall C vl,
          value_list vl
      -> value (tm_new C vl)
with value_list : list tm -> Prop :=
  | v_nil : value_list (nil _)  
  | v_cons : forall v l,
          value v
      -> value_list l
      -> value_list (v :: l).

Hint Constructors value.
Hint Constructors value_list.

(* constructor declarations *)
Inductive K : Set :=
  | constructor : 
         className -> list (varName * className) 
      -> list varName -> list varName -> K.

(* method declarations *)
Inductive M : Set :=
  | method : 
         className -> methodName 
      -> list (varName * className) -> tm -> M.

(* class declarations *)
Inductive CL : Set :=
  | class : 
         className -> className 
      -> list (fieldName * className) -> K -> list M -> CL.

(* class table *)
Definition CT : Set := alist CL. 

(* The special class Object is "named" zero. *)
Definition Object :=  zero.

(* ---------------------------------------------------------------------- *)
(* EXERCISE: Translate the following FJ class table (from TAPL 
   chapter 19) into Coq. 

      class A extends Object { A() { super(); } }

      class B extends Object { B() { super(); } }

      class Pair extends Object {
        Object fst;
        Object snd;

        Pair(Object fst, Object snd) {
          super(); this.fst=fst; this.snd=snd; }

        Pair setfst(Object newfst) {
          return new Pair(newfst, this.snd); } 
      }
*)

Definition A : className := one.
Definition B : className := two.
Definition Pair : className := three.
Definition fst : fieldName := one.
Definition snd : fieldName := two.
Definition setfst : methodName := three.
Definition newfst : methodName := four.

Definition CL_A :=
  class A Object (nil _) (constructor A (nil _) (nil _) (nil _)) (nil _).

Definition CL_B :=
   (* SOLUTION *)
  class B Object (nil _) (constructor B (nil _) (nil _) (nil _)) (nil _).

Definition CL_Pair :=
  (* SOLUTION *)
  class Pair Object [(fst,A),(snd,B)] 
    (constructor Pair [(fst,A),(snd,B)] (nil _) [fst,snd]) 
    [method Pair setfst [(newfst,A)] (tm_new Pair [tm_var newfst, tm_field (tm_var this) snd])].

(* Dummy definitions (so that Coq accepts the lecture notes)
Definition CL_B := CL_A.
Definition CL_Pair := CL_A.
*)

Definition ct : CT :=
  [(A, CL_A),
   (B, CL_B),
   (Pair, CL_Pair)].
  
(* ---------------------------------------------------------------------- *)
(* Subtyping *)

Reserved Notation "S <: T" (at level 70).

Inductive subtyping : CT -> className -> className -> Prop :=
  | S_Refl : forall CT C,
         subtyping CT C C
  | S_Trans : forall CT C D E,
         subtyping CT C D
      -> subtyping CT D E
      -> subtyping CT C E
  | S_Ext : forall CT C D Cf K M,
         lookup _ C CT = Some _ (class C D Cf K M)
      -> subtyping CT C D.

Tactic Notation "subtyping_cases" tactic(first) tactic(c) :=
  first;
  [ c "S_Refl" | c "S_Trans" | c "S_Ext" ].

(* ---------------------------------------------------------------------- *)
(* Auxiliary Definitions *)

(* Field lookup *)
Inductive fields : CT -> className -> list (fieldName * className) -> Prop :=
   | f_obj : forall CT C,
          C = Object -> fields CT C (nil _)
   | f_class : forall CT C D Cf K M' Dg, 
          lookup _ C CT = Some _ (class C D Cf K M')  
     -> fields CT D Dg 
     -> fields CT C  (Dg ++ Cf).
Hint Constructors fields.

(* Search for a method in a list of method delarations *)
Fixpoint mlookup (m : methodName) (l : list M) {struct l} : option M :=
  match l with
  | nil => None _
  | (method T m' Cx t) :: l' =>
      if eqnat m m' then Some _ (method T m' Cx t) else mlookup m l'
  end.

(* Method type lookup *)
Inductive mtype : CT -> methodName -> className -> list className -> className -> Prop :=
   | mt_class : forall CT m C D Cf K M' Cx t B' B,
         lookup _ C CT = Some _ (class C D Cf K M')  
     -> mlookup m M' = Some _ (method B m Cx t)
     -> B' = map _ _ (fun p => match p with (f,ss) => ss end) Cx
     -> mtype CT m C B' B
   | mt_super : forall CT m C D Cf K M' B' B,
         lookup _ C CT = Some _ (class C D Cf K M')  
     -> mlookup m M' = None _
     -> mtype CT m D B' B
     -> mtype CT m C B' B.
Hint Constructors mtype.

(* Method body lookup *)
Inductive mbody : CT -> methodName -> className -> list varName -> tm -> Prop :=
   | mb_class : forall CT m C D Cf K M' Cx t x B,
         lookup _ C CT = Some _ (class C D Cf K M')  
     -> mlookup m M' = Some _ (method B m Cx t)
     -> x = map _ _ (fun p => match p with (f,_) => f end) Cx
     -> mbody CT m C x t
   | mb_super : forall CT m C D Cf K M' x t,
         lookup _ C CT = Some _ (class C D Cf K M')  
     -> mlookup m M' = None _
     -> mbody CT m D x t
     -> mbody CT m C x t.
Hint Constructors mbody.

Inductive method_not_defined_in_class : CT -> methodName -> className -> Prop :=
  | mndic_obj : forall CT m,
      method_not_defined_in_class CT m Object
  | mndic_class : forall CT m C D Cf K M',
      lookup _ C CT = Some _ (class C D Cf K M') 
   -> mlookup m M' = None _     
   -> method_not_defined_in_class CT m D
   -> method_not_defined_in_class CT m C.

(* Valid method overriding *)
Inductive override : CT -> methodName -> className -> list className -> className -> Prop :=
   | m_notboundinsuper : forall CT m D C' C0,
        method_not_defined_in_class CT m D
     -> override CT m D C' C0
   | m_over : forall CT m D C' C0 D' D0,
        mtype CT m D D' D0  
     -> C' = D'
     -> C0=D0
     -> override CT m D C' C0.
Hint Constructors override.

(* ---------------------------------------------------------------------- *)
(* Evaluation *)

(* A missing list utility: [combine] takes two lists and produces a
   list of pairs of corresponding elements. If the lists given to
   [combine] are of different lengths, the result will have the same
   number of elements as the shorter input. *)
Fixpoint combine (X Y : Set) (l : list X) (l' : list Y) {struct l} : list (X*Y) :=
  match l,l' with
    | xx::tl, yy::tl' => (xx,yy)::(combine _ _ tl tl')
    | _, _ => nil _
  end.

(* Substitution *)

(* The substitution function for FJ is superficially quite a bit more
   complex than what we have seen before, but conceptually it is not
   much different.  The important thing to realize is that we are
   performing a SIMULTANEOUS substitution for a whole list of
   variables ([x]) by a list of values ([u]) in a term [t].  Moreover,
   we treat the variable [this] specially: the parameters [C] and [v]
   represent the class name and field values of the "current object",
   and the substitution function reconstitutes copies of this object
   in place of any occurrences of [this] in the body [t]. 

   The other technical complication in the definition is that we are
   actually performing a *simultaneous* recursion on terms and lists
   of terms; this is the reason for the two occurrences of [fix] in
   the body.  You do not need to understand this part in detail --
   just the overall purpose of the substitution function is enough.
*)
Fixpoint subst (x: list varName) (u: list tm) 
               (C:className) (v:list tm) 
               (t:tm) {struct t} : tm :=
  match t with
  | tm_var this => tm_new C v
  | tm_var yy => 
      match lookup _ yy (combine _ _ x u) with
        | Some u1 => u1
        | None => t
      end
  | tm_field t1 f => 
      tm_field (subst x u C v t1) f
  | tm_invoke t1 m ll => 
      tm_invoke (subst x u C v t1) m 
        ((fix subst_list (x: list varName) (u: list tm) 
                         (C:className) (v:list tm) (tl: list tm) 
                         {struct tl} : list tm := 
          match tl with 
            | nil => nil _ 
            | (h::t) => (subst x u C v h) :: (subst_list x u C v t) 
          end) x u C v ll)
  | tm_new D ll => 
      tm_new D ((fix subst_list (x: list varName) (u: list tm) 
                                (C:className) (v:list tm) (tl: list tm) 
                                {struct tl} : list tm := 
                match tl with 
                | nil => nil _ 
                | (h::t) => (subst x u C v h) :: (subst_list x u C v t) 
                end) x u C v ll)
  | tm_cast D t1 => tm_cast D (subst x u C v t1)
  end.

Inductive eval : CT -> tm -> tm -> Prop :=
  | E_ProjNew : forall CT C v fj vj Cf,
         value_list v
      -> fields CT C Cf
      -> (lookup _ fj 
           (combine _ _ (map _ _ (fun p => match p with (f,_) => f end) Cf) v)) 
          = Some _ vj
      -> eval CT (tm_field (tm_new C v) fj) (vj)
  | E_InvkNew : forall CT C v m u t0 x,
         value_list v
      -> value_list u
      -> mbody CT m C x t0
      -> eval CT (tm_invoke (tm_new C v) m u) (subst x u C v t0)
  | E_CastNew : forall CT C D v,
         value_list v
      -> subtyping CT C D
      -> eval CT (tm_cast D (tm_new C v)) (tm_new C v)
  | E_Field : forall CT f t t',
         eval CT t t'
      -> eval CT (tm_field t f) (tm_field t' f)
  | E_Invk_Recv : forall CT l m t0 t0',
         eval CT t0 t0'
      -> eval CT (tm_invoke t0 m l) (tm_invoke t0' m l)
  | E_Invk_Arg : forall CT v0 m v ti ti' t,
         value v0
      -> value_list v
      -> eval CT ti ti'
      -> eval CT (tm_invoke v0 m (v ++ [ti] ++ t)) 
                 (tm_invoke v0 m (v ++ [ti'] ++ t))
  | E_New_Arg : forall CT C v ti ti' t,
         value_list v
      -> eval CT ti ti'
      -> eval CT (tm_new C (v ++ [ti] ++ t)) (tm_new C (v ++ [ti'] ++ t))
  | E_Cast : forall CT C t t',
         eval CT t t'
      -> eval CT (tm_cast C t) (tm_cast C t').

Hint Constructors eval.
Tactic Notation "eval_cases" tactic(first) tactic(c) :=
  first;
  [ c "E_ProjNew" | c "E_InvkNew" | c "E_CastNew" |
  | c "E_Field" | c "E_Invk_Recv" | c "E_Invk_Arg" | c "E_New_Arg"
  | c "E_Cast"].

(* EXERCISE: Prove that
      new Pair(new A(), new B()).setfst(new B())
   evaluates in one step to
      new Pair(new B(), new Pair(new A(), new B()).snd)
*)
Lemma eval_exercise : 
  eval
     ct
     (tm_invoke 
        (tm_new Pair [tm_new A (nil _), tm_new B (nil _)])
        setfst 
        [tm_new B (nil _)])
     (tm_new Pair [tm_new B (nil _), 
                   tm_field (tm_new Pair [tm_new A (nil _), tm_new B (nil _)]) snd]).
Proof.
  (* SOLUTION *)
  assert (
      eval
         ct
         (tm_invoke 
            (tm_new Pair [tm_new A (nil _), tm_new B (nil _)])
            setfst 
            [tm_new B (nil _)])
         (subst [newfst] [tm_new B (nil _)] Pair [tm_new A (nil _), tm_new B (nil _)]
             (tm_new Pair [tm_var newfst, tm_field (tm_var this) snd]))  ).
  eapply E_InvkNew.
  eauto. eauto. eauto.
  eapply mb_class. simpl. unfold CL_Pair. reflexivity.
  simpl. reflexivity.
  simpl. reflexivity.
  simpl in H. assumption.
Qed.

(* ---------------------------------------------------------------------- *)
(* Typing *)

Notation context := (alist className).

Definition empty : context := nil _.

Reserved Notation "CT >> Gamma |- t ~ T" (at level 69).

Inductive typing : CT -> context -> tm -> className -> Prop :=
  | T_Var : forall CT Gamma x C,
           binds _ x C Gamma
      -> CT >> Gamma |- (tm_var x) ~ C
  | T_Field : forall CT Gamma t0 fi Ci C0 Cf,
           CT >> Gamma |- t0 ~ C0
      -> fields CT C0 Cf
      -> (lookup _ fi Cf) = Some _ Ci
      -> CT >> Gamma |- (tm_field t0 fi) ~ Ci
  | T_Invk : forall CT Gamma t0 m tl C C0 Dl,
           CT >> Gamma |- t0 ~ C0
      -> mtype CT m C0 Dl C
      -> typing_list CT Gamma tl Dl
      -> CT >> Gamma |- (tm_invoke t0 m tl) ~ C
  | T_New : forall CT Gamma tl C Df,
           fields CT C Df
      -> typing_list CT Gamma tl 
            (map _ _ (fun p => match p with (f,s) => s end) Df)
      -> CT >> Gamma |- (tm_new C tl) ~ C
  | T_UCast : forall CT Gamma t0 C D,
           CT >> Gamma |- t0 ~ D
      -> subtyping CT D C
      -> CT >> Gamma |- (tm_cast C t0) ~ C
  | T_DCast : forall CT Gamma t0 C D,
           CT >> Gamma |- t0 ~ D
      -> subtyping CT C D
      -> C<>D
      -> CT >> Gamma |- (tm_cast C t0) ~ C
  | T_SCast : forall CT Gamma t0 C D,
           CT >> Gamma |- t0 ~ D
      -> ~ (subtyping CT C D)
      -> ~ (subtyping CT D C)
      -> CT >> Gamma |- (tm_cast C t0) ~ C

with typing_list : CT -> context -> list tm -> list className -> Prop :=
   | TL_nil  : forall CT Gamma,
              typing_list CT Gamma (nil _) (nil _)
   | TL_cons : forall CT Gamma t tl C Cl T,
              typing CT Gamma t T
         -> subtyping CT T C
	 -> typing_list CT Gamma tl Cl 
	 -> typing_list CT Gamma (t::tl) (C::Cl)

where "CT >> Gamma |- t ~ T" := (typing CT Gamma t T).

Tactic Notation "typing_cases" tactic(first) tactic(c) :=
  first;
  [   c "T_Var" | c "T_Field" | c "T_Invk" | c "T_New" 
    | c "T_UCast" | c "T_DCast" | c "T_SCast" ].

(* Method typing *)
Inductive mtyping : CT -> className -> methodName 
                 -> list (varName * className) -> tm ->className -> Prop :=
   | m_ok : forall CT C0 m Cx t0 C D Cl Df K Ml E0,
         CT >> (this,C) :: Cx |- t0 ~ E0  
     -> subtyping CT E0 C0
     -> lookup _ C CT = Some _ (class C D Df K Ml)
     -> override CT m D Cl C0
     -> mtyping CT C0 m Cx t0 C.
Hint Constructors mtyping.

Inductive mlist_typing : CT -> list M -> className -> Prop :=
   | m_ok_nil : forall CT C,
         mlist_typing CT (nil _) C
   | m_ok_cons : forall CT M C Ml C0 m Cx t0,
         M = method C0 m Cx t0
     -> mtyping CT C0 m Cx t0 C
     -> mlist_typing CT (M :: Ml) C.
Hint Constructors mlist_typing.

(* Class typing *)
Inductive ctyping : CT -> className -> className 
                 -> list (fieldName * className) -> K -> list M -> Prop :=
   | c_ok : forall CT C D Cf K Ml Dg,
         K = constructor C (Dg ++ Cf) 
               (map _ _ (fun p => match p with (f,s) => f end) Dg) 
               (map _ _ (fun p => match p with (f,s) => f end) Cf) 
     -> fields CT D Dg
     -> mlist_typing CT Ml C 
     -> ctyping CT C D Cf K Ml.
Hint Constructors ctyping.

(* The whole class table is well formed if each class definition in it is well typed. *)
Definition wf_class_table (ct : CT) : Prop :=
  forall C D Cf K M',
        lookup _ C ct = Some _ (class C D Cf K M')
     -> ctyping ct C D Cf K M'.

(* EXERCISE (optional): Prove that the class table we defined above is
   well formed. *)
Lemma wf_exercise : 
  wf_class_table ct.
Proof.
  (* SOLUTION *)
  unfold wf_class_table.
  intros.
  simpl in H.
  remember (eqnat C A) as r. destruct r.
  CASE "C = A".
    inversion_clear H.
    apply c_ok with (Dg := nil (fieldName * className)). 
    simpl. subst. reflexivity.
    auto. auto. 
  remember (eqnat C B) as r. destruct r.
  CASE "C = B".
    inversion_clear H.
    apply c_ok with (Dg := nil (fieldName * className)). 
    simpl. subst. reflexivity.
    auto. auto. 
  remember (eqnat C Pair) as r. destruct r.
  CASE "C = Pair".
    inversion_clear H.
    apply c_ok with (Dg := nil (fieldName * className)). 
    simpl. subst. reflexivity.
    auto.
    eapply m_ok_cons.
    reflexivity.
    eapply m_ok.
    eapply T_New.
    eapply f_class. eauto. simpl. unfold CL_Pair. reflexivity.
    auto. simpl. 
    eapply TL_cons. eapply T_Var. unfold binds. simpl. reflexivity.
    eapply S_Refl.
    eapply TL_cons. eapply T_Field. eapply T_Var. unfold binds. simpl. reflexivity.
    eapply f_class. simpl. unfold CL_Pair. reflexivity.
    eapply f_obj. reflexivity. simpl. reflexivity. apply S_Refl.
    eapply TL_nil. apply S_Refl. simpl. unfold CL_Pair. reflexivity.
    apply m_notboundinsuper with (C' := nil className). eapply mndic_obj.  
  CASE "C is something else".
    solve by inversion.
Qed.

(* ---------------------------------------------------------------------- *)
(* Properties *)

Theorem preservation : forall CT Gamma t t' C,
     CT >> Gamma |- t ~ C
  -> eval CT t t'
  -> exists C', (subtyping CT C' C) /\ (CT >> Gamma |- t' ~ C').
Proof.
Admitted.

(* Evaluation context *)
Inductive E : Set :=
   | ec_hole : E                     (* hole *)
   | ec_field : E -> fieldName -> E (* field access *)
   | ec_invk_recv : E -> methodName -> list tm -> E (* method inv (receiver) *)
   | ec_invk_arg : tm -> methodName -> list tm -> E -> list tm -> E (* method invocation (arg) *)
   | ec_new : className -> list tm -> E -> list tm -> E (* object creation (arg) *)
   | ec_cast : className -> E -> E (* cast *).

Inductive well_formed_context : E -> Prop :=
   | wfc_hole : well_formed_context ec_hole 
   | wfc_field : forall c c1 f,
          c = ec_field c1 f
     -> well_formed_context c1
     -> well_formed_context c
   | wfc_invk_recv : forall c c1 m l,
          c = ec_invk_recv c1 m l
     -> well_formed_context c1
     -> well_formed_context c
   | wfc_invk_arg : forall c c1 v m vl tl,
          c = ec_invk_arg v m vl c1 tl
     -> value v
     -> value_list vl
     -> well_formed_context c
   | wfc_new : forall c C vl c1 tl,
          c = ec_new C vl c1 tl
     -> value_list vl
     -> well_formed_context c1
     -> well_formed_context c
   | wfc_cast : forall c c1 C,
          c = ec_cast C c1
     -> well_formed_context c1
     -> well_formed_context c.

Fixpoint E_subst (e: E) (t: tm) {struct e} : tm :=
  match e with 
   | ec_hole => t 
   | ec_field c f => tm_field (E_subst c t) f
   | ec_invk_recv c m l => tm_invoke (E_subst c t) m l
   | ec_invk_arg v m vl c tl => tm_invoke v m (vl ++ [(E_subst c t)] ++ tl)
   | ec_new C vl c tl => tm_new C (vl ++ [(E_subst c t)] ++ tl)
   | ec_cast C c => tm_cast C (E_subst c t)
  end.

Theorem progress : forall CT (*Gamma*) t C,
     CT >> (*Gamma*) empty |- t ~ C
  -> (value t) 
    \/ (exists t', eval CT t t')
     \/ (exists e:E, exists D:className, exists vl:list tm, 
(*              (well_formed_context e) 
           /\*) (t = E_subst e (tm_cast C (tm_new D vl))) 
           /\ (value_list vl) 
           /\ (~ subtyping CT D C)).
Proof.
Admitted.

End FeatherweightJava.