(** * Software Foundations, Formally Benjamin C. Pierce Version of 11/28/2007 Before handing in this file with your homework solutions, please fill in the names of all members of your group: FILL IN HERE Also, please tell us roughly how many person-hours you spent on this assignment (i.e., if you worked in a group, give us the SUM of the number of hours spent by each person individually). FILL IN HERE Any thoughts or comments on this assignment? FILL IN HERE *) (* ---------------------------------------------------------------------- *) Require Export lec19. (* ====================================================================== *) (* Motivation for Subtyping *) Module STLCWithRecords'. Export STLCWithRecords. Export STLCWithRecords.Examples. (* TAPL chapter 15 is useful background for this week's material. *) (* Here is a slight variant of the non-example that we saw in Lecture 18. *) Lemma typing_nonexample_2 : ~ exists T, empty |- (\r~[[y~B-->B]], r # y) @ [|x==(\z~A,z),y==(\z~B,z)|] ~ T. Proof. intros C. destruct C. inversion H. subst. clear H. inversion H3. subst. clear H3. inversion H5. Qed. (* This term is not typable because it involves an application of a function that wants a one-field record to an argument that actually provides two fields. But this is a bit silly. The only thing the body of the function can possibly do with its record argument [r] is project the field [y] from it (or add fields at the front): nothing else is allowed by the type. So the presence or absence of an extra [x] field should make no difference at all. In general, a longer record type is "better than" a shorter one (with just a subset of its fields), in the sense that any value belonging to the longer record type can be used SAFELY in any context expecting the shorter record type. This idea can be pushed further. For example, suppose: f ~ C --> [[x~A-->A,y~B-->B]] g ~ (C-->[[y~B-->B]]) --> D That is, [f] is a function that yields a record of type [[x~A-->A,y~B-->B]], and [g] is a higher-order function that its argument to yield a record of type [[y~B-->B]]. Then it is safe to pass [f] as an argument to [g] even though their types do not match up precisely, because the only thing [g] can do with [f] is to apply it to some argument (of type [C]). The result of each such application will actually be a two-field record, while [g] will be expecting only a record with a single field; but this is safe, since the only thing [g] can then do is to project out the single field that it knows about, and this will certainly be among the two fields that are present. The general principle at work here is called SUBTYPING. We say that "[S] is a subtype of [T]", written [S <: T], if a value of type [S] can safely be used in any context where a value of type [T] is expected. This principle plays a fundamental role in many widely used programming languages -- in particular, it is closely related to the notion of SUBCLASSING in object-oriented languages. Our goal for today is to add subtyping to the simply typed lambda-calculus with records. This involves two steps: - 1. Defining subtyping as a binary relation between types. - 2. Enriching the typing relation to take subtyping into account. The second step is actually very simple. We add just a single rule to the typing relation -- the so-called RULE OF SUBSUMPTION: | T_Sub : forall Gamma t S T, Gamma |- t ~ S -> S <: T -> Gamma |- t ~ T This rule says, intuitively, that we can "forget" some of the information that we know about a term. For example, we may know that [t] is a record with two fields (i.e., [ S = [[x~A-->A,y~B-->B]] ], but choose to forget about one of the fields (i.e., [ T = [[y~B-->B]] ] so that we can pass [t] to a function that expects just a single-field record. The first step -- the definition of the relation [S <: T] -- is where all the action is. Let's look at each of the clauses of its definition. To begin with, we need to formalize the basic intuition about record types that a longer record should be a subtype of a shorter one. Since our record types are presented in a "binary" form (with constructors for nil and cons, rather than a single constructor that assembles a whole multi-field record all at once), we need to formulate subtyping in the same terms. This can be accomplished by a combination of three rules. First, any record type is a subtype of the empty record type: | S_Rcdwidth : forall k T1 T2, [[k~T1;T2]] <: [[]] Second, we can drop later fields of a multi-field record while keeping earlier fields: | S_Rcddepth : forall k S1 T1 T2, -> S2 <: T2 -> [[k~S1;S2]] <: [[k~S1;T2]] For example, we can use S_Rcddepth and S_Rcdwidth together to show that [[y~B-->B, x~A-->A]] <: [[y~B-->B]]. Actually, we can generalize S_Rcddepth a little to allow the type of the first field to vary at the same time: | S_Rcddepth : forall k S1 S2 T1 T2, S1 <: T1 -> S2 <: T2 -> [[k~S1;S2]] <: [[k~T1;T2]] Now we can use S_Rcddepth and S_Rcdwidth together to show that [[ y~[[z~B-->B]], x~A-->A ]] <: [[ y~[[]] ]]. The example we originally had in mind was [[x~A-->A,y~B-->B]] <: [[y~B-->B]]. We haven't quite achieved this yet: using just S_Rcddepth and S_Rcdwidth we can only drop fields from the END of a record type. To handle the original example, we also need to be able to reorder fields: | S_Rcdperm : forall k1 k2 S1 S2 S3, k1 <> k2 -> [[k1~S1; [[k2~S2; S3]] ]] <: [[k2~S2; [[k1~S1; S3]] ]] For example, [[x~A-->A,y~B-->B]] <: [[y~B-->B,x~A-->A]]. We can also include a general rule of TRANSITIVITY, which says (intuitively) that, if [S] is better than [U] and [U] is better than [T], then [S] is better than [T]. | S_Trans : forall S U T, S <: U -> U <: T -> S <: T This rule allows us to paste together the proof that [[x~A-->A,y~B-->B]] <: [[y~B-->B,x~A-->A]] using S_Rcdperm with the earlier proof that [[y~B-->B, x~A-->A]] <: [[y~B-->B]] using S_Rcddepth and S_Rcdwidth, to yield a proof that [[x~A-->A,y~B-->B]] <: [[y~B-->B]]. This completes the subtyping rules for records. To finish the whole definition of subtyping, we need to consider how each of the other type constructors behaves with respect to subtyping. Since we're dealing with a very simple language with just arrows and records, we have only arrows left to deal with. The rule suggested above says that two arrow types are in the subtype relation if their results are: | S_Arrow : forall S1 T1 T2, S2 <: T2 -> S1-->S2 <: S1-->T2 We can generalize this rule a little so that the arguments of the two arrow types are also in a subtype relation: | S_Arrow : forall S1 S2 T1 T2, T1 <: S1 -> S2 <: T2 -> S1-->S2 <: T1-->T2 Notice, here, that the argument types are in the subtype relation "the other way round": we demand that [T1] be a subtype of [S1]. This is called CONTRAVARIANCE. Finally, we add one last structural rule, which (together with transitivity) ensures that the subtype relation is a preorder: | S_Refl : forall T, T <: T We can stop here, if we like. But it is common practice to go one further step and add to the language one new type constant, called Top, together with a subtyping rule that places it above every other type in the subtype relation: | S_Top : forall S, S <: Top *) End STLCWithRecords'. (* ====================================================================== *) (* STLC with records and subtyping *) Module STLCWithSubtyping. (* ---------------------------------------------------------------------- *) (* Syntax *) (* Almost exactly the same as before -- just adding the Top type *) Inductive ty : Set := | ty_top : ty | ty_base : nat -> ty | ty_arrow : ty -> ty -> ty | ty_rcd_nil : ty | ty_rcd_cons : nat -> ty -> ty -> ty. Tactic Notation "ty_cases" tactic(first) tactic(c) := first; [ c "ty_top" | c "ty_base" | c "ty_arrow" | c "ty_rcd_nil" | c "ty_rcd_cons"]. Inductive tm : Set := | tm_var : nat -> tm | tm_app : tm -> tm -> tm | tm_abs : nat -> ty -> tm -> tm | tm_rcd_nil : tm | tm_rcd_cons : nat -> tm -> tm -> tm | tm_proj : tm -> nat -> tm. Tactic Notation "tm_cases" tactic(first) tactic(c) := first; [ c "tm_var" | c "tm_app" | c "tm_abs" | c "tm_rcd_nil" | c "tm_rcd_cons" | c "tm_proj" ]. Notation A := (ty_base one). Notation B := (ty_base two). Notation C := (ty_base three). Notation Top := ty_top. Notation "S --> T" := (ty_arrow S T) (at level 20, right associativity). Notation "[[ ]]" := (ty_rcd_nil). Notation "[[ l1 ~ T1 ; T2 ]]" := (ty_rcd_cons l1 T1 T2). Notation "! n" := (tm_var n) (at level 39). Notation "\ x ~ T , t" := (tm_abs x T t) (at level 42). Notation "r @ s" := (tm_app r s) (at level 40, left associativity). Notation "r # s" := (tm_proj r s) (at level 41). Notation "[| |]" := (tm_rcd_nil). Notation "[| l1 == t1 ; t2 |]" := (tm_rcd_cons l1 t1 t2). (* Convenient abbreviations for multi-field record types and terms *) Notation "[[ l1 ~ T1 ]]" := ( [[ l1~T1; [[]] ]]). Notation "[[ l1 ~ T1 , l2 ~ T2 ]]" := ( [[ l1~T1; [[l2~T2]] ]]). Notation "[[ l1 ~ T1 , l2 ~ T2 , l3 ~ T3 ]]" := ( [[ l1~T1; [[l2~T2,l3~T3]] ]]). Notation "[| l1 == T1 |]" := ([| l1==T1; [||] |]). Notation "[| l1 == T1 , l2 == T2 |]" := ([| l1==T1; [|l2==T2|] |]). Notation "[| l1 == T1 , l2 == T2 , l3 == T3 |]" := ([| l1==T1; [|l2==T2,l3==T3|] |]). (* ---------------------------------------------------------------------- *) (* Operational semantics *) (* Exactly the same as before... *) Reserved Notation "{ x |-> s } t" (at level 17). Fixpoint subst (x:nat) (s:tm) (t:tm) {struct t} : tm := match t with | !y => if eqnat x y then s else t | \y~T, t1 => if eqnat x y then t else \y~T, {x |-> s}t1 | t1 @ t2 => ({x |-> s}t1) @ ({x |-> s}t2) | [||] => [||] | [| l==t1; t2 |] => [| l=={x |-> s}t1; {x |-> s}t2 |] | t # k => ({x |-> s}t) # k end where "{ x |-> s } t" := (subst x s t). Inductive value : tm -> Prop := | v_abs : forall x T t, value (\x~T, t) | v_rcd_nil : value [||] | v_rcd_cons : forall l t1 t2, value t1 -> value t2 -> value [| l==t1; t2|]. Inductive eval : tm -> tm -> Prop := | E_AppAbs : forall x T t12 v2, value v2 -> eval ((\x~T, t12) @ v2) ({x |-> v2} t12) | E_App1 : forall t1 t1' t2, eval t1 t1' -> eval (t1 @ t2) (t1' @ t2) | E_App2 : forall v1 t2 t2', value v1 -> eval t2 t2' -> eval (v1 @ t2) (v1 @ t2') | E_Rcdcons1 : forall k t1 t1' t2, eval t1 t1' -> eval [|k==t1;t2|] [|k==t1';t2|] | E_Rcdcons2 : forall k t1 t2 t2', value t1 -> eval t2 t2' -> eval [|k==t1;t2|] [|k==t1;t2'|] | E_ProjRcdcons1 : forall k t1 t2, value t1 -> value t2 -> eval ([|k==t1;t2|] # k) t1 | E_ProjRcdcons2 : forall k k' t1 t2, value t1 -> value t2 -> k <> k' -> eval ([|k'==t1;t2|] # k) (t2 # k) | E_Proj : forall k t t', eval t t' -> eval (t # k) (t' # k). Tactic Notation "eval_cases" tactic(first) tactic(c) := first; [ c "E_AppAbs" | c "E_App1" | c "E_App2" | | c "E_Rcdcons1" | c "E_Rcdcons2" | c "E_ProjRcdcons1" | c "E_ProjRcdcons2" | c "E_Proj"]. Notation evalmany := (refl_trans_closure' _ eval). (* ---------------------------------------------------------------------- *) (* Well-formed types *) (* Here we have to pay something for the syntactic flexibility that we introduced when we chose to represent records as "nil/cons lists" of single fields (rather than with a single monolithic [ty_rcd] constructor). The syntax allows us to write down crazy types like [[l~A;C-->C]], where the "tail" of a record type is not a record type, and [[l~A;l~B]], where the same field is bound twice. These "junk types" will mess up the properties of the system if we are not careful. The solution is to define a predicate [well_formed] that is true only of "non-junky" types and, in the subtyping and typing rules, demand that all the types involved by well formed. *) Inductive doesn't_bind (k:nat) : ty -> Prop := | db_nil : doesn't_bind k [[]] | db_cons : forall k' T1 T2, k <> k' -> doesn't_bind k T2 -> doesn't_bind k [[k'~T1;T2]]. Inductive record_type : ty -> Prop := | rt_nil : record_type [[]] | rt_cons : forall k T1 T2, record_type [[k~T1;T2]]. Inductive well_formed : ty -> Prop := | wf_top : well_formed Top | wf_base : forall n, well_formed (ty_base n) | wf_arrow : forall T1 T2, well_formed T1 -> well_formed T2 -> well_formed (T1-->T2) | wf_rcdnil : well_formed [[]] | wf_rcdcons : forall k T1 T2, well_formed T1 -> well_formed T2 -> record_type T2 (* these two conditions... *) -> doesn't_bind k T2 (* ...are the crux of the definition *) -> well_formed [[k~T1;T2]]. Hint Constructors doesn't_bind. Hint Constructors record_type. Hint Constructors well_formed. (* ---------------------------------------------------------------------- *) (* Subtyping *) (* The definition of subtyping is just what we sketched in the motivating discussion, except that we add well-formedness side conditions to some of the rules. *) Reserved Notation "S <: T" (at level 70). Inductive subtyping : ty -> ty -> Prop := | S_Refl : forall T, well_formed T -> T <: T | S_Trans : forall S U T, S <: U -> U <: T -> S <: T | S_Top : forall S, well_formed S -> S <: Top | S_Arrow : forall S1 S2 T1 T2, T1 <: S1 -> S2 <: T2 -> S1-->S2 <: T1-->T2 | S_Rcdwidth : forall k T1 T2, well_formed [[k~T1;T2]] -> [[k~T1;T2]] <: [[]] | S_Rcddepth : forall k S1 S2 T1 T2, S1 <: T1 -> S2 <: T2 -> well_formed [[k~S1;S2]] -> well_formed [[k~T1;T2]] -> [[k~S1;S2]] <: [[k~T1;T2]] | S_Rcdperm : forall k1 k2 S1 S2 S3, well_formed [[k1~S1; [[k2~S2; S3]] ]] -> k1 <> k2 -> [[k1~S1; [[k2~S2; S3]] ]] <: [[k2~S2; [[k1~S1; S3]] ]] where "S <: T" := (subtyping S T). Tactic Notation "subtyping_cases" tactic(first) tactic(c) := first; [ c "S_Refl" | c "S_Trans" | c "S_Top" | c "S_Arrow" | c "S_Rcdwidth" | c "S_Rcddepth" | c "S_Rcdperm" ]. (* ---------------------------------------------------------------------- *) (* Typing *) (* The typing relation is exactly the same as the simply typed lambda-calculus with records from Lecture 18, except that we've added (a) the rule of subsumption, [T_Sub], and (b) some well-formedness side conditions. *) Notation context := (alist ty). Definition empty : context := nil _. Fixpoint ty_rcd_lookup (k:nat) (t:ty) {struct t} : option ty := match t with | ty_rcd_cons k' T' t' => if eqnat k k' then Some _ T' else ty_rcd_lookup k t' | _ => None _ end. Definition ty_rcd_binds (k:nat) (Tk:ty) (T:ty) := ty_rcd_lookup k T = Some _ Tk. Reserved Notation "Gamma |- t ~ T" (at level 69). Inductive typing : context -> tm -> ty -> Prop := | T_Var : forall Gamma x T, binds _ x T Gamma -> well_formed T -> Gamma |- (!x) ~ T | T_Abs : forall Gamma x T1 T2 t, well_formed T1 -> [(x,T1)] ++ Gamma |- t ~ T2 -> Gamma |- (\x~T1, t) ~ T1-->T2 | T_App : forall S T Gamma t1 t2, Gamma |- t1 ~ (S-->T) -> Gamma |- t2 ~ S -> Gamma |- (t1 @ t2) ~ T | T_Rcdnil : forall Gamma, Gamma |- [||] ~ ty_rcd_nil | T_Rcdcons : forall Gamma k t1 t2 T1 T2, Gamma |- t1 ~ T1 -> Gamma |- t2 ~ T2 -> well_formed [[k~T1;T2]] -> Gamma |- [|k==t1;t2|] ~ [[k~T1;T2]] | T_Proj : forall Gamma k Tk t T, Gamma |- t ~ T -> ty_rcd_binds k Tk T -> Gamma |- t # k ~ Tk | T_Sub : forall Gamma t S T, Gamma |- t ~ S -> S <: T -> Gamma |- t ~ T where "Gamma |- t ~ T" := (typing Gamma t T). Tactic Notation "typing_cases" tactic(first) tactic(c) := first; [ c "T_Var" | c "T_Abs" | c "T_App" | c "T_Rcdnil" | c "T_Rcdcons" | c "T_Proj" | c "T_Sub" ]. (* ---------------------------------------------------------------------- *) (* Examples *) Module Examples. Notation l := (S (S (S O))). Notation k := (S (S (S (S O)))). Notation x := (S (S (S (S (S O))))). Notation y := (S (S (S (S (S (S O)))))). Notation z := (S (S (S (S (S (S (S O))))))). Notation r := (S (S (S (S (S (S (S (S O)))))))). Notation s := (S (S (S (S (S (S (S (S (S O))))))))). Definition nat_in_tm : nat -> tm := tm_var. Coercion nat_in_tm : nat >-> tm. (* When we're using these rules to prove that concrete expressions are well typed, proving all the well-formedness side conditions by hand can get annoying. Fortunately, with a tiny bit of extra work we can get [auto] to generate them completely automatically. *) (* The following little tactic allows [auto] to automatically prove inequalities between small numeric constants (e.g., different field labels). *) Ltac unequal_nats := unfold not; intros; solve by inversion. Hint Extern 2 (~ (?x = ?y)) => unequal_nats. (* The [Hint Extern] command adds an arbitrary tactic to the hints database used by [auto]. This is not as generally useful as it sounds, since these external hints are used only at the *leaves* of auto's proof search, but for the present purpose this is exactly what we need. *) (* Combining this hint with the [Hint Constructors well_formed] command that we gave above gives [auto] what it needs to automatically solve goals of the form [well_formed T]. *) Lemma subtyping_example_0 : C --> [[x~A-->A,y~B-->B]] <: C --> [[]]. Proof. apply S_Arrow. apply S_Refl. auto. apply S_Rcdwidth; auto. Qed. Lemma subtyping_example_1 : [[x~A-->A,y~B-->B]] <: [[y~B-->B]]. Proof. (* The structure of this proof was sketched in the long comment above. *) (* FILL IN HERE (and delete "Admitted") *) Admitted. Lemma subtyping_example_2 : (C-->C)-->[[x~A-->A,y~B-->B]] <: (C-->C)-->[[y~B-->B]]. Proof. (* FILL IN HERE (and delete "Admitted") *) Admitted. Lemma subtyping_example_3 : [[]]-->[[x~A]] <: [[y~B]]-->[[]]. Proof. (* FILL IN HERE (and delete "Admitted") *) Admitted. Lemma subtyping_example_4 : [[x~A,y~B,z~C]] <: [[z~C,y~B,x~A]]. Proof. (* OPTIONAL EXERCISE *) Admitted. Lemma typing_example_0 : empty |- [|x==(\z~A,z),y==(\z~B,z)|] ~ [[x~A-->A, y~B-->B]]. Proof. (* OPTIONAL EXERCISE *) Admitted. Lemma typing_example_1 : empty |- (\r~[[y~B-->B]], r # y) @ [|x==(\z~A,z),y==(\z~B,z)|] ~ B-->B. Proof. (* This proof is similar to the one you did on the last homework, but you'll need to add a little bit. *) (* FILL IN HERE (and delete "Admitted") *) Admitted. Lemma typing_example_2 : empty |- (\s~(C-->C)-->[[y~B-->B]], (s @ (\z~C,z)) # y) @ (\z~C-->C, [|x==(\z~A,z),y==(\z~B,z)|]) ~ B-->B. Proof. (* OPTIONAL EXERCISE *) Admitted. End Examples. (* ---------------------------------------------------------------------- *) (* Technical lemmas about well-formedness *) (* The essential property we want is that whenever we prove any statement about subtyping or typing, all of the types involved are well formed. The following technical lemmas show that we did this correctly. (That is, they explain why we added well-formedness side conditions in some places in the subtyping and typing rules but not in others: we added just enough to achieve these properties, leaving off side conditions about well-formedness when they could be deduced from information already available, e.g. in [S_Arrow].) *) Lemma subtypes__well_formed : forall S T, S <: T -> well_formed S /\ well_formed T. Proof. (* OPTIONAL EXERCISE *) Admitted. Lemma fields_of_well_formed_types_are_well_formed : forall k Tk T, well_formed T -> ty_rcd_binds k Tk T -> well_formed Tk. Proof. intros k Tk T WFT. induction T; intros B; inversion WFT; subst; try solve [solve by inversion]. CASE "ty_rcd_cons". unfold ty_rcd_binds in B. simpl in B. destruct (eqnat k n). SCASE "k = n". inversion B. subst. assumption. SCASE "k <> n". apply IHT2. assumption. assumption. Qed. Lemma typing__well_formed : forall Gamma t T, Gamma |- t ~ T -> well_formed T. Proof. (* OPTIONAL EXERCISE *) Admitted. Lemma ty_rcd_binds__record_type : forall k Tk T, ty_rcd_binds k Tk T -> well_formed T -> record_type T. Proof. intros k Tk T B WF. destruct T; inversion B. apply rt_cons. Qed. (* ---------------------------------------------------------------------- *) (* Technical lemmas about subtyping *) Lemma sub_inversion_arrow : forall U V1 V2, U <: V1 --> V2 -> exists U1, exists U2, (U=U1-->U2) /\ (V1<:U1) /\ (U2<:V2). Proof. (* FILL IN HERE (and delete "Admitted") *) Admitted. Lemma subtypes_of_rcd_types_are_rcd_types : forall S T, S <: T -> record_type T -> record_type S. Proof. (* FILL IN HERE (and delete "Admitted") *) Admitted. (* The next proof is annotated with an informal proof sketch, as a template for the homework exercises later on... *) Lemma ty_rcd_binds__sub : forall U V l Vl, U <: V -> ty_rcd_binds l Vl V -> exists Ul, ty_rcd_binds l Ul U /\ Ul <: Vl. Proof. intros U V l Vl SUB. generalize dependent Vl. (* By induction on a derivation of [U <: V]. The cases where T is -->, Top, or [[]] cannot occur. We consider the remaining cases in turn. *) (subtyping_cases (induction SUB) CASE); intros Vl BV; try solve [solve by inversion]. CASE "S_Refl". (* If the final rule in the derivation is S_Refl, the form of S_Refl implies that U = V, and the result is immediate by S_Refl. *) eapply ex_intro. apply conj. eassumption. apply S_Refl. eauto using fields_of_well_formed_types_are_well_formed. CASE "S_Trans". (* If the final rule is S_Trans, the form of the rule tells us that S <: U and U <: T for some U. The induction hypotheses for the premise U <: T tells us that there is some Ul such that exists Ul : ty, ty_rcd_binds l Ul U /\ Ul <: Vl. From this, the induction hypotheses for the premise S <: U gives us an Sl such that exists Sl : ty, ty_rcd_binds l Sl S /\ Sl <: Ul. Since Sl <: Vl (by transitivity), Sl satisfies our requirements. *) assert (exists Ul : ty, ty_rcd_binds l Ul U /\ Ul <: Vl). apply IHSUB2; assumption. destruct H. rename witness into Ul. destruct H. assert (exists Sl : ty, ty_rcd_binds l Sl S /\ Sl <: Ul). apply IHSUB1; assumption. destruct H1. rename witness into Sl. destruct H1. apply ex_intro with (witness := Sl). apply conj. assumption. eauto using S_Trans. CASE "S_Rcddepth". (* If the final rule is S_RcdDepth, the form of the rule tells us that S has the form [[k ~ S1; S2]] and T has the form [[k ~ T1; T2]], with S1<:T1 and S2<:T2. There are two cases to consider: - If l = k, then the result is immediate (choose S1 for Ul and note that we know S1<:T1). - If l <> k, the result follows by the IH. *) unfold ty_rcd_binds. simpl. unfold ty_rcd_binds in BV. simpl in BV. destruct (eqnat l k). SCASE "first binding". inversion BV. subst T1. apply ex_intro with (witness := S1). apply conj; auto. SCASE "later binding". unfold ty_rcd_binds in IHSUB2. apply IHSUB2. assumption. CASE "S_Rcdperm". (* If the final rule is S_RcdPerm, the form of the rule tells us that S has the form [[k1 ~ S1; [[k2 ~ S2; S3]]]] and T has the form [[k2 ~ S2; [[k1 ~ S1; S3]]]]. There are three cases to consider, depending on whether l is k1, k2, or some other label; each case follows immediately using S_Refl. *) unfold ty_rcd_binds. unfold ty_rcd_binds in BV. simpl. simpl in BV. inversion H. subst. inversion H5; subst. remember (eqnat l k1) as E1. destruct E1. SCASE "l = k1". apply eq_symm in HeqE1. apply eqnat_yes in HeqE1. subst k1. apply eqnat_n_n' in H0. rewrite H0 in BV. inversion BV. rewrite <- H2. eauto using ex_intro, S_Refl. SCASE "l <> k1". destruct (eqnat l k2). SSCASE "l = k2". inversion BV. subst. eauto using conj, ex_intro, S_Refl. SSCASE "l <> k2". eapply ex_intro. apply conj. eassumption. apply S_Refl. eapply fields_of_well_formed_types_are_well_formed. apply H9. unfold ty_rcd_binds. eassumption. Qed. (* To reason about subtyping involving records, we need to be able to take a more "global" view of subtyping relations involving record types, talking about all the fields together (and ignoring their order) instead of one at a time. *) Definition fields_sub (S T : ty) := forall k Tk, ty_rcd_binds k Tk T -> exists Sk, ty_rcd_binds k Sk S /\ Sk <: Tk. (* EXERCISE: Annotate this proof with an informal proof sketch, following the model of proof of [ty_rcd_binds__sub] above and [progress''] in Lecture 19. *) Lemma subtype__fields_sub : forall S T, S <: T -> fields_sub S T. Proof. (* FILL IN HERE *) (* This line is included just to maintain the invariant that exercises are always marked with "FILL IN HERE". Delete and fill in your proof sketch in comments throughout the proof. *) unfold fields_sub. unfold ty_rcd_binds. intros S T H. (subtyping_cases (induction H) CASE); intros l Tl B; try solve [solve by inversion]; simpl in B; simpl. CASE "S_Refl". apply ex_intro with (witness:=Tl). apply conj. assumption. apply S_Refl. eapply fields_of_well_formed_types_are_well_formed. eassumption. unfold ty_rcd_binds. eassumption. CASE "S_Trans". assert (exists Ul : ty, ty_rcd_lookup l U = Some _ Ul /\ Ul <: Tl). auto using IHsubtyping2. destruct H1. rename witness into Ul. destruct H1. assert (exists Sl : ty, ty_rcd_lookup l S = Some _ Sl /\ Sl <: Ul). auto using IHsubtyping1. destruct H3. rename witness into Sl. destruct H3. eauto using ex_intro, conj, S_Trans. CASE "S_Rcddepth". remember (eqnat l k) as E. destruct E. SCASE "l = k". inversion B. subst. eauto 10 using ex_intro, conj. SCASE "l <> k". apply IHsubtyping2. assumption. CASE "S_Rcdperm". remember (eqnat l k1) as E. destruct E. SCASE "l = k1". apply eq_symm in HeqE. apply eqnat_yes in HeqE. subst k1. apply eqnat_n_n' in H0. rewrite H0 in B. inversion B. subst. inversion H. eauto using ex_intro, conj, S_Refl. SCASE "l <> k1". rewrite B. inversion H. subst. inversion H5. subst. destruct (eqnat l k2). SSCASE "l = k2". inversion B. subst. eauto using ex_intro, conj, S_Refl. SSCASE "l <> k2". eapply ex_intro. apply conj. reflexivity. apply S_Refl. eapply fields_of_well_formed_types_are_well_formed. apply H9. unfold ty_rcd_binds. eassumption. Qed. Lemma fields_sub_refl : forall S, well_formed S -> fields_sub S S. Proof. intros S WF. unfold fields_sub. intros k Tk B. eapply ex_intro. apply conj. eassumption. apply S_Refl. eauto using ex_intro, conj, S_Refl. eapply fields_of_well_formed_types_are_well_formed; eauto. Qed. (* EXERCISE: Annotate this proof with an informal proof sketch, as described above. *) Lemma fields_sub_trans : forall S U T, fields_sub S U -> fields_sub U T -> fields_sub S T. Proof. (* FILL IN HERE *) unfold fields_sub. intros S U T B1 B2. intros k Tk B. assert (exists Uk : ty, ty_rcd_binds k Uk U /\ Uk <: Tk). auto using B2. destruct H. rename witness into Uk. destruct H. assert (exists Sk : ty, ty_rcd_binds k Sk S /\ Sk <: Uk). auto using B1. destruct H1. rename witness into Sk. destruct H1. apply ex_intro with (witness := Sk). eauto using conj, S_Trans. Qed. (* ---------------------------------------------------------------------- *) (* Technical lemmas about typing *) Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2, Gamma |- s ~ T1-->T2 -> value s -> exists x, exists S1, exists s2, s = \x~S1,s2. Proof. (* FILL IN HERE (and delete "Admitted") *) Admitted. Lemma canonical_forms_of_rcd_types : forall Gamma s T, Gamma |- s ~ T -> value s -> record_type T -> s = [||] \/ exists k, exists s1, exists s2, s = [|k==s1;s2|] /\ value s1 /\ value s2. Proof. intros Gamma s T H. (typing_cases (induction H) CASE); intros V R; inversion V; inversion R; subst; try solve [eauto using subtypes_of_rcd_types_are_rcd_types]. auto using or_introl. eauto 8 using or_intror, ex_intro. Qed. Lemma typing_inversion_abs : forall Gamma x S1 t2 T1 T2, Gamma |- \x~S1,t2 ~ T1-->T2 -> (exists S2, T1 <: S1 /\ S2 <: T2 /\ [(x,S1)] ++ Gamma |- t2 ~ S2). Proof. intros Gamma x S1 t2 T1 T2 H. remember (\x~S1,t2) as t. remember (T1-->T2) as T. generalize dependent T2. generalize dependent T1. (typing_cases (induction H) CASE); subst; try solve [intros; solve by inversion]. CASE "T_Abs". intros. inversion HeqT. inversion Heqt. subst. subst. rename T3 into S2. apply ex_intro with (witness := S2). apply conj. apply S_Refl. assumption. apply conj. apply S_Refl. eapply typing__well_formed. apply H0. assumption. CASE "T_Sub". intros. subst. assert (exists U1, exists U2, (S=U1-->U2) /\ (T1<:U1) /\ (U2<:T2)). apply sub_inversion_arrow. assumption. destruct H1. destruct H1. destruct H1. destruct H2. rename witness into U1. rename witness0 into U2. subst. assert (exists S2, U1<:S1 /\ S2<:U2 /\ [(x, S1)] ++ Gamma |- t2 ~ S2). SCASE "Pf of assertion". apply IHtyping; reflexivity. destruct H1. rename witness into S2. destruct H1. destruct H4. apply ex_intro with (witness:=S2). apply conj. eapply S_Trans; eassumption. (* WHY??? *) apply conj. eapply S_Trans; eassumption. assumption. Qed. Lemma typing_inversion_rcd : forall Gamma k t1 t2 T, Gamma |- [|k==t1; t2|] ~ T -> exists T1, exists T2, [[k~T1; T2]] <: T /\ fields_sub [[k~T1; T2]] T /\ Gamma |- t1 ~ T1 /\ Gamma |- t2 ~ T2. Proof. intros Gamma k t1 t2 T H. remember [|k==t1; t2|] as t. (typing_cases (induction H) CASE); subst; try solve [solve by inversion]. CASE "T_Rcdcons". inversion Heqt. subst. clear Heqt. apply ex_intro with (witness := T1). apply ex_intro with (witness := T2). inversion H1. auto using conj, S_Refl, fields_sub_refl. CASE "T_Sub". assert (exists T1 : ty, exists T2 : ty, [[k ~ T1; T2]] <: S /\ fields_sub [[k ~ T1; T2]] S /\ Gamma |- t1 ~ T1 /\ Gamma |- t2 ~ T2). SCASE "Pf". assert (well_formed S /\ well_formed T). apply subtypes__well_formed. assumption. destruct H1. eauto using IHtyping, subtypes_of_rcd_types_are_rcd_types. destruct H1. rename witness into T1. destruct H1. rename witness into T2. destruct H1. destruct H2. destruct H3. assert (fields_sub [[k ~ T1; T2]] T). SCASE "Pf". eauto using fields_sub_trans, subtype__fields_sub. assert ([[k ~ T1; T2]] <: T). SCASE "Pf". eauto using S_Trans. eauto 7 using ex_intro. Qed. (* A last technical lemma recording a small fact that will be useful in one spot below. *) Lemma empty_record's_type_binds_nothing : forall Gamma T, Gamma |- [||] ~ T -> forall k Tk, ~ ty_rcd_binds k Tk T. Proof. intros Gamma T H. remember [||] as t. (typing_cases (induction H) CASE); try solve [solve by inversion]. CASE "T_Rcdnil". intros k Tk C. inversion C. CASE "T_Sub". intros k Tk C. assert (exists Sk, ty_rcd_binds k Sk S /\ Sk <: Tk). eauto using ty_rcd_binds__sub. destruct H1. destruct H1. generalize dependent H1. apply IHtyping. assumption. Qed. (* ---------------------------------------------------------------------- *) (* Preservation and progress theorems *) (* The overall architecture of the proofs of preservation and progress is the same as for the system without subtyping: we begin with some technical lemmas about contexts, leading up to weakening, then prove the key substitution lemma, from which preservation follows by a fairly easy induction; progress also uses the same plan as before. However, the details of the reasoning in each case are somewhat complicated by the extra flexibility introduced by subsumption. In particular, all the proofs in this section now go by induction on typing derivations rather than by induction on terms. This, in turn, requires some fiddling around with [remember], [generalize dependent], and such at the beginning of each one, to get the induction hypothesis into exactly the right form. *) Lemma drop_duplicate_binding : forall Delta t T y U, Delta ++ [(y,U)] |- t ~ T -> (exists V, binds _ y V Delta) -> Delta |- t ~ T. Proof. intros Delta t T y U H. remember (Delta ++ [(y,U)]) as Gamma. generalize dependent Delta. (typing_cases (induction H) CASE); intros Delta Eq B. CASE "T_Var". subst. apply T_Var. remember (eqnat x y) as eq. destruct eq. SCASE "x = y". apply eq_symm in Heqeq. assert (x = y). apply eqnat_yes. assumption. subst x. unfold binds. unfold binds in H. unfold binds in B. inversion B. assert (lookup ty y (Delta ++ [(y, U)]) = Some _ witness). apply shadowed_binding with (v:=U). assumption. rewrite -> H in H2. inversion H2. auto. SCASE "x <> y". unfold binds. apply not_last_binding with (j:=y)(v:=U). auto. auto. assumption. CASE "T_Abs". apply T_Abs. assumption. apply IHtyping. subst Gamma. unfold alist. apply append_assoc. unfold binds. simpl. remember (eqnat y x) as E. destruct E. SCASE "y = x". eapply ex_intro. auto. SCASE "y <> x". auto. CASE "T_App". apply T_App with (S:=S); auto. CASE "T_Rcdnil". apply T_Rcdnil. CASE "T_Rcdcons". apply T_Rcdcons; auto. CASE "T_Proj". eapply T_Proj; eauto. CASE "T_Sub". eapply T_Sub; eauto. Qed. (* LATER *) (* Note that we have to prove this by induction on typing derivations, not on terms as we did before. OPTIONAL EXERCISE: Why? *) Hint Unfold binds. Lemma weakening_preserves_typing : forall Gamma x U t T, Gamma |- t ~ T -> Gamma ++ [(x,U)] |- t ~ T. Proof. intros Gamma x U t T H. typing_cases (induction H) CASE. CASE "T_Var". auto using T_Var, found_before. CASE "T_Abs". auto using T_Abs. CASE "T_App". eauto 6 using T_App. CASE "T_Rcdnil". auto using T_Rcdnil. CASE "T_Rcdcons". auto using T_Rcdcons. CASE "T_Proj". eauto 6 using T_Proj. CASE "T_Sub". eauto using T_Sub. Qed. Lemma weakening_empty_preserves_typing : forall Gamma t T, empty |- t ~ T -> Gamma |- t ~ T. Proof. intros Gamma t T H. assert (forall Delta, reverse _ Delta |- t ~ T). CASE "Pf of assertion". induction Delta. SCASE "Delta empty". auto. SCASE "Delta cons". simpl. destruct x. assert ( snoc _ (reverse _ Delta) (n,t0) = (reverse _ Delta) ++ [(n,t0)]). apply snoc_append. rewrite -> H0. auto using weakening_preserves_typing. assert (reverse _ (reverse _ Gamma) = Gamma). apply reverse_reverse. rewrite <- H1. auto. Qed. Lemma substitution_preserves_typing : forall Delta x U v t S, Delta ++ [(x,U)] |- t ~ S -> empty |- v ~ U -> not_bound_in _ x Delta -> Delta |- {x|->v}t ~ S. Proof. intros Delta x U v t S H. remember (Delta ++ [(x,U)]) as Gamma. generalize dependent Delta. (typing_cases (induction H) CASE); intros Delta Eq V B; subst; simpl. CASE "T_Var". remember (eqnat x x0) as test. destruct test. SCASE "x = x0". apply eq_symm in Heqtest. apply eqnat_yes in Heqtest. subst x0. assert (lookup ty x (Delta ++ [(x, U)]) = Some _ U). SSCASE "Proof of assertion". apply last_binding. assumption. unfold binds in H. rewrite -> H1 in H. inversion H. subst U. apply weakening_empty_preserves_typing. assumption. SCASE "x <> x0". apply T_Var. unfold binds. apply not_last_binding with (j:=x)(v:=U). apply eqnat_symm. apply eq_symm. assumption. auto. assumption. CASE "T_Abs". simpl. remember (eqnat x x0) as test. destruct test. SCASE "x = x0". apply eq_symm in Heqtest. apply eqnat_yes in Heqtest. subst x0. apply T_Abs. assumption. apply drop_duplicate_binding with (y:=x)(U:=U). assumption. unfold binds. simpl. assert (eqnat x x = yes). apply eqnat_n_n. rewrite -> H1. eauto using ex_intro. SCASE "x <> x0". apply T_Abs. assumption. apply IHtyping. simpl. reflexivity. assumption. unfold not_bound_in. simpl. apply eq_symm in Heqtest. rewrite Heqtest. assumption. CASE "T_App". eauto using T_App. CASE "T_Rcdnil". apply T_Rcdnil. CASE "T_Rcdcons". auto using T_Rcdcons. CASE "T_Proj". eauto using T_Proj. CASE "T_Sub". eauto using T_Sub. Qed. Theorem preservation : forall t t' T, empty |- t ~ T -> eval t t' -> empty |- t' ~ T. Proof. remember empty as Gamma. intros t t' T Hty He. generalize dependent t'. (typing_cases (induction Hty) CASE); intros t' He; inversion He; subst. CASE "T_App". SCASE "E_AppAbs". rename T0 into T11. assert (exists T2, S <: T11 /\ T2 <: T /\ [(x,T11)] ++ empty |- t12 ~ T2) as TI. SSCASE "Pf". apply typing_inversion_abs. assumption. inversion TI. rename witness into T12. inversion H. inversion H1. simpl in H4. apply T_Sub with (S:=T12). apply substitution_preserves_typing with (U:=T11). assumption. apply T_Sub with (S:=S); assumption. unfold binds. unfold empty. apply empty_alist_binds_nothing. assumption. CASE "T_App". SCASE "E_App1". apply T_App with (S:=S); auto. CASE "T_App". SCASE "E_App2". apply T_App with (S:=S); auto. CASE "T_Rcdcons". SCASE "E_Rcdcons1"; auto using T_Rcdcons. SCASE "E_Rcdcons2"; auto using T_Rcdcons. CASE "T_Proj". SCASE "E_ProjRcdcons1". assert (exists T1, exists T2, [[k~T1; T2]] <: T /\ fields_sub [[k~T1; T2]] T /\ empty |- t' ~ T1 /\ empty |- t2 ~ T2) as TI. SSCASE "Pf". apply typing_inversion_rcd. assumption. eauto using typing__well_formed. inversion TI. rename witness into T1. inversion H0. rename witness into T2. clear TI. clear H0. clear IHHty. clear He. clear Hty. destruct H1. destruct H1. destruct H3. assert (T1 <: Tk). SSCASE "Pf". assert (exists T1', ty_rcd_binds k T1' [[k ~ T1; T2]] /\ T1' <: Tk). SSSCASE "Pf". eauto using ty_rcd_binds__sub. destruct H6. rename witness into T1'. destruct H6. unfold ty_rcd_binds in H6. simpl in H6. assert (eqnat k k = yes). apply eqnat_n_n. rewrite H8 in H6. inversion H6. subst. assumption. apply T_Sub with (S:=T1); auto. SCASE "E_ProjRcdcons2". assert (exists T1, exists T2, [[k'~T1; T2]] <: T /\ fields_sub [[k'~T1; T2]] T /\ empty |- t1 ~ T1 /\ empty |- t2 ~ T2) as TI. SSCASE "Pf". apply typing_inversion_rcd. assumption. eauto using typing__well_formed. inversion TI. rename witness into T1. inversion H0. rename witness into T2. clear TI. clear H0. clear IHHty. clear He. clear Hty. inversion H1. clear H1. inversion H4. clear H4. inversion H6. clear H6. assert (exists Sk, ty_rcd_binds k Sk [[k'~T1; T2]] /\ Sk <: Tk) as B. SSCASE "Pf". unfold fields_sub in H1. apply H1. assumption. destruct B. rename witness into Sk. unfold ty_rcd_binds in H6. simpl in H6. apply eqnat_n_n' in H5. rewrite H5 in H6. destruct H6. apply T_Sub with (S := Sk). apply T_Proj with (T:=T2); assumption. assumption. SCASE "E_Proj". eapply T_Proj; eauto. CASE "T_Sub". eauto using T_Sub. eauto using T_Sub. eauto using T_Sub. eauto using T_Sub. eauto using T_Sub. eauto using T_Sub. eauto using T_Sub. eauto using T_Sub. Qed. (* EXERCISE: Annotate this proof with an informal proof sketch, as described above. *) Theorem progress : forall t T, empty |- t ~ T -> value t \/ exists t', eval t t'. Proof. (* FILL IN HERE *) intros t T Hty. remember empty as Gamma. (typing_cases (induction Hty) (CASE)); subst. CASE "T_Var". solve by inversion. CASE "T_Abs". apply or_introl. apply v_abs. CASE "T_App". assert (value t1 \/ (exists t' : tm, eval t1 t')) as IH1. auto. assert (value t2 \/ (exists t' : tm, eval t2 t')) as IH2. auto. apply or_intror. inversion IH1. SCASE "t1 value". inversion IH2; subst. SSCASE "t1 value / t2 value". assert (exists x, exists T11, exists t12, t1 = \x~T11,t12). SSSCASE "Pf". eapply canonical_forms_of_arrow_types; eassumption. destruct H1. rename witness into x. destruct H1. rename witness into T11. destruct H1. rename witness into t12. subst. eauto using ex_intro, E_AppAbs. SSCASE "t1 value / t2 steps". inversion H0. eauto using ex_intro, E_App2. SCASE "t1 steps". inversion H. eauto using ex_intro, E_App1. CASE "T_Rcdnil". apply or_introl. apply v_rcd_nil. CASE "T_Rcdcons". assert (value t1 \/ (exists t' : tm, eval t1 t')) as IH1. auto. assert (value t2 \/ (exists t' : tm, eval t2 t')) as IH2. auto. inversion IH1. SCASE "t1 value". inversion IH2; subst. SSCASE "t1 value / t2 value". auto using or_introl, v_rcd_cons. SSCASE "t1 value / t2 steps". apply or_intror. inversion H1. eauto using ex_intro, E_Rcdcons2. SCASE "t1 steps". apply or_intror. inversion H0. eauto using ex_intro, E_Rcdcons1. CASE "T_Proj". apply or_intror. assert (value t \/ (exists t' : tm, eval t t')) as IH. auto. inversion IH. SCASE "t is a value". assert (t = [||] \/ exists k, exists s1, exists s2, t = [|k==s1;s2|] /\ value s1 /\ value s2). SSCASE "Pf". eapply canonical_forms_of_rcd_types. eassumption. assumption. eauto using ty_rcd_binds__record_type, typing__well_formed. destruct H1. SSSCASE "t is the empty record". subst. assert (~ ty_rcd_binds k Tk T). SSSSCASE "Pf". eauto using empty_record's_type_binds_nothing. contradiction. SSSCASE "t is a cons-record". destruct H1. rename witness into k'. destruct H1. rename witness into s1. destruct H1. rename witness into s2. destruct H1. destruct H2. subst. remember (eqnat k k') as e. apply eq_symm in Heqe. destruct e. SSCASE "k = k'". apply eqnat_yes in Heqe. rewrite <- Heqe. eauto using ex_intro, E_ProjRcdcons1. SSCASE "k <> k'". apply eqnat_no in Heqe. eapply ex_intro. apply E_ProjRcdcons2; assumption. SCASE "t steps to some t'". inversion H0. eauto using ex_intro, E_Proj. CASE "T_Sub". apply IHHty. reflexivity. Qed. End STLCWithSubtyping.