adamc@223: (* Copyright (c) 2008-2009, Adam Chlipala adamc@170: * adamc@170: * This work is licensed under a adamc@170: * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0 adamc@170: * Unported License. adamc@170: * The license text is available at: adamc@170: * http://creativecommons.org/licenses/by-nc-nd/3.0/ adamc@170: *) adamc@170: adamc@170: (* begin hide *) adamc@170: Require Import String List. adamc@170: adamc@204: Require Import Axioms Tactics. adamc@170: adamc@170: Set Implicit Arguments. adamc@170: (* end hide *) adamc@170: adamc@170: adamc@170: (** %\chapter{Type-Theoretic Interpreters}% *) adamc@170: adamc@170: (** TODO: Prose for this chapter *) adamc@170: adamc@170: adamc@170: (** * Simply-Typed Lambda Calculus *) adamc@170: adamc@170: Module STLC. adamc@170: Inductive type : Type := adamc@170: | Nat : type adamc@170: | Arrow : type -> type -> type. adamc@170: adamc@170: Infix "-->" := Arrow (right associativity, at level 60). adamc@170: adamc@170: Section vars. adamc@170: Variable var : type -> Type. adamc@170: adamc@170: Inductive exp : type -> Type := adamc@170: | Var : forall t, adamc@170: var t adamc@170: -> exp t adamc@170: adamc@170: | Const : nat -> exp Nat adamc@170: | Plus : exp Nat -> exp Nat -> exp Nat adamc@170: adamc@170: | App : forall t1 t2, adamc@170: exp (t1 --> t2) adamc@170: -> exp t1 adamc@170: -> exp t2 adamc@170: | Abs : forall t1 t2, adamc@170: (var t1 -> exp t2) adamc@170: -> exp (t1 --> t2). adamc@170: End vars. adamc@170: adamc@170: Definition Exp t := forall var, exp var t. adamc@170: adamc@170: Implicit Arguments Var [var t]. adamc@170: Implicit Arguments Const [var]. adamc@170: Implicit Arguments Plus [var]. adamc@170: Implicit Arguments App [var t1 t2]. adamc@170: Implicit Arguments Abs [var t1 t2]. adamc@170: adamc@170: Notation "# v" := (Var v) (at level 70). adamc@170: adamc@170: Notation "^ n" := (Const n) (at level 70). adamc@171: Infix "+^" := Plus (left associativity, at level 79). adamc@170: adamc@170: Infix "@" := App (left associativity, at level 77). adamc@170: Notation "\ x , e" := (Abs (fun x => e)) (at level 78). adamc@170: Notation "\ ! , e" := (Abs (fun _ => e)) (at level 78). adamc@170: adamc@172: Definition zero : Exp Nat := fun _ => ^0. adamc@172: Definition one : Exp Nat := fun _ => ^1. adamc@172: Definition zpo : Exp Nat := fun _ => zero _ +^ one _. adamc@172: Definition ident : Exp (Nat --> Nat) := fun _ => \x, #x. adamc@172: Definition app_ident : Exp Nat := fun _ => ident _ @ zpo _. adamc@172: Definition app : Exp ((Nat --> Nat) --> Nat --> Nat) := fun _ => adamc@172: \f, \x, #f @ #x. adamc@172: Definition app_ident' : Exp Nat := fun _ => app _ @ ident _ @ zpo _. adamc@172: adamc@174: (* EX: Define an interpreter for [Exp]s. *) adamc@174: adamc@174: (* begin thide *) adamc@170: Fixpoint typeDenote (t : type) : Set := adamc@170: match t with adamc@170: | Nat => nat adamc@170: | t1 --> t2 => typeDenote t1 -> typeDenote t2 adamc@170: end. adamc@170: adamc@223: Fixpoint expDenote t (e : exp typeDenote t) : typeDenote t := adamc@223: match e with adamc@170: | Var _ v => v adamc@170: adamc@170: | Const n => n adamc@170: | Plus e1 e2 => expDenote e1 + expDenote e2 adamc@170: adamc@170: | App _ _ e1 e2 => (expDenote e1) (expDenote e2) adamc@170: | Abs _ _ e' => fun x => expDenote (e' x) adamc@170: end. adamc@170: adamc@170: Definition ExpDenote t (e : Exp t) := expDenote (e _). adamc@174: (* end thide *) adamc@170: adamc@172: Eval compute in ExpDenote zero. adamc@172: Eval compute in ExpDenote one. adamc@172: Eval compute in ExpDenote zpo. adamc@172: Eval compute in ExpDenote ident. adamc@172: Eval compute in ExpDenote app_ident. adamc@172: Eval compute in ExpDenote app. adamc@172: Eval compute in ExpDenote app_ident'. adamc@172: adamc@174: (* EX: Define a constant-folding function for [Exp]s. *) adamc@174: adamc@174: (* begin thide *) adamc@170: Section cfold. adamc@170: Variable var : type -> Type. adamc@170: adamc@223: Fixpoint cfold t (e : exp var t) : exp var t := adamc@223: match e with adamc@170: | Var _ v => #v adamc@170: adamc@170: | Const n => ^n adamc@170: | Plus e1 e2 => adamc@170: let e1' := cfold e1 in adamc@170: let e2' := cfold e2 in adamc@204: match e1', e2' return _ with adamc@170: | Const n1, Const n2 => ^(n1 + n2) adamc@171: | _, _ => e1' +^ e2' adamc@170: end adamc@170: adamc@170: | App _ _ e1 e2 => cfold e1 @ cfold e2 adamc@170: | Abs _ _ e' => Abs (fun x => cfold (e' x)) adamc@170: end. adamc@170: End cfold. adamc@170: adamc@170: Definition Cfold t (E : Exp t) : Exp t := fun _ => cfold (E _). adamc@174: (* end thide *) adamc@170: adamc@174: (* EX: Prove the correctness of constant-folding. *) adamc@174: adamc@174: (* begin thide *) adamc@170: Lemma cfold_correct : forall t (e : exp _ t), adamc@170: expDenote (cfold e) = expDenote e. adamc@170: induction e; crush; try (ext_eq; crush); adamc@170: repeat (match goal with adamc@170: | [ |- context[cfold ?E] ] => dep_destruct (cfold E) adamc@170: end; crush). adamc@170: Qed. adamc@170: adamc@170: Theorem Cfold_correct : forall t (E : Exp t), adamc@170: ExpDenote (Cfold E) = ExpDenote E. adamc@170: unfold ExpDenote, Cfold; intros; apply cfold_correct. adamc@170: Qed. adamc@174: (* end thide *) adamc@170: End STLC. adamc@171: adamc@171: adamc@171: (** * Adding Products and Sums *) adamc@171: adamc@171: Module PSLC. adamc@174: (* EX: Extend the development with products and sums. *) adamc@174: adamc@174: (* begin thide *) adamc@171: Inductive type : Type := adamc@171: | Nat : type adamc@171: | Arrow : type -> type -> type adamc@171: | Prod : type -> type -> type adamc@171: | Sum : type -> type -> type. adamc@174: (* end thide *) adamc@171: adamc@171: Infix "-->" := Arrow (right associativity, at level 62). adamc@171: Infix "**" := Prod (right associativity, at level 61). adamc@171: Infix "++" := Sum (right associativity, at level 60). adamc@171: adamc@174: (* begin thide *) adamc@171: Section vars. adamc@171: Variable var : type -> Type. adamc@171: adamc@171: Inductive exp : type -> Type := adamc@171: | Var : forall t, adamc@171: var t adamc@171: -> exp t adamc@171: adamc@171: | Const : nat -> exp Nat adamc@171: | Plus : exp Nat -> exp Nat -> exp Nat adamc@171: adamc@171: | App : forall t1 t2, adamc@171: exp (t1 --> t2) adamc@171: -> exp t1 adamc@171: -> exp t2 adamc@171: | Abs : forall t1 t2, adamc@171: (var t1 -> exp t2) adamc@171: -> exp (t1 --> t2) adamc@171: adamc@171: | Pair : forall t1 t2, adamc@171: exp t1 adamc@171: -> exp t2 adamc@171: -> exp (t1 ** t2) adamc@171: | Fst : forall t1 t2, adamc@171: exp (t1 ** t2) adamc@171: -> exp t1 adamc@171: | Snd : forall t1 t2, adamc@171: exp (t1 ** t2) adamc@171: -> exp t2 adamc@171: adamc@171: | Inl : forall t1 t2, adamc@171: exp t1 adamc@171: -> exp (t1 ++ t2) adamc@171: | Inr : forall t1 t2, adamc@171: exp t2 adamc@171: -> exp (t1 ++ t2) adamc@171: | SumCase : forall t1 t2 t, adamc@171: exp (t1 ++ t2) adamc@171: -> (var t1 -> exp t) adamc@171: -> (var t2 -> exp t) adamc@171: -> exp t. adamc@171: End vars. adamc@171: adamc@171: Definition Exp t := forall var, exp var t. adamc@174: (* end thide *) adamc@171: adamc@171: Implicit Arguments Var [var t]. adamc@171: Implicit Arguments Const [var]. adamc@171: Implicit Arguments Abs [var t1 t2]. adamc@171: Implicit Arguments Inl [var t1 t2]. adamc@171: Implicit Arguments Inr [var t1 t2]. adamc@171: adamc@171: Notation "# v" := (Var v) (at level 70). adamc@171: adamc@171: Notation "^ n" := (Const n) (at level 70). adamc@172: Infix "+^" := Plus (left associativity, at level 78). adamc@171: adamc@171: Infix "@" := App (left associativity, at level 77). adamc@171: Notation "\ x , e" := (Abs (fun x => e)) (at level 78). adamc@171: Notation "\ ! , e" := (Abs (fun _ => e)) (at level 78). adamc@171: adamc@171: Notation "[ e1 , e2 ]" := (Pair e1 e2). adamc@171: Notation "#1 e" := (Fst e) (at level 75). adamc@171: Notation "#2 e" := (Snd e) (at level 75). adamc@171: adamc@171: Notation "'case' e 'of' x => e1 | y => e2" := (SumCase e (fun x => e1) (fun y => e2)) adamc@171: (at level 79). adamc@171: adamc@172: Definition swap : Exp (Nat ** Nat --> Nat ** Nat) := fun _ => adamc@172: \p, [#2 #p, #1 #p]. adamc@172: Definition zo : Exp (Nat ** Nat) := fun _ => [^0, ^1]. adamc@172: Definition swap_zo : Exp (Nat ** Nat) := fun _ => swap _ @ zo _. adamc@172: adamc@172: Definition natOut : Exp (Nat ++ Nat --> Nat) := fun _ => adamc@172: \s, case #s of x => #x | y => #y +^ #y. adamc@172: Definition ns1 : Exp (Nat ++ Nat) := fun _ => Inl (^3). adamc@172: Definition ns2 : Exp (Nat ++ Nat) := fun _ => Inr (^5). adamc@172: Definition natOut_ns1 : Exp Nat := fun _ => natOut _ @ ns1 _. adamc@172: Definition natOut_ns2 : Exp Nat := fun _ => natOut _ @ ns2 _. adamc@172: adamc@174: (* begin thide *) adamc@171: Fixpoint typeDenote (t : type) : Set := adamc@171: match t with adamc@171: | Nat => nat adamc@171: | t1 --> t2 => typeDenote t1 -> typeDenote t2 adamc@171: | t1 ** t2 => typeDenote t1 * typeDenote t2 adamc@171: | t1 ++ t2 => typeDenote t1 + typeDenote t2 adamc@171: end%type. adamc@171: adamc@223: Fixpoint expDenote t (e : exp typeDenote t) : typeDenote t := adamc@223: match e with adamc@171: | Var _ v => v adamc@171: adamc@171: | Const n => n adamc@171: | Plus e1 e2 => expDenote e1 + expDenote e2 adamc@171: adamc@171: | App _ _ e1 e2 => (expDenote e1) (expDenote e2) adamc@171: | Abs _ _ e' => fun x => expDenote (e' x) adamc@171: adamc@171: | Pair _ _ e1 e2 => (expDenote e1, expDenote e2) adamc@171: | Fst _ _ e' => fst (expDenote e') adamc@171: | Snd _ _ e' => snd (expDenote e') adamc@171: adamc@171: | Inl _ _ e' => inl _ (expDenote e') adamc@171: | Inr _ _ e' => inr _ (expDenote e') adamc@171: | SumCase _ _ _ e' e1 e2 => adamc@171: match expDenote e' with adamc@171: | inl v => expDenote (e1 v) adamc@171: | inr v => expDenote (e2 v) adamc@171: end adamc@171: end. adamc@171: adamc@171: Definition ExpDenote t (e : Exp t) := expDenote (e _). adamc@174: (* end thide *) adamc@171: adamc@172: Eval compute in ExpDenote swap. adamc@172: Eval compute in ExpDenote zo. adamc@172: Eval compute in ExpDenote swap_zo. adamc@172: adamc@172: Eval compute in ExpDenote natOut. adamc@172: Eval compute in ExpDenote ns1. adamc@172: Eval compute in ExpDenote ns2. adamc@172: Eval compute in ExpDenote natOut_ns1. adamc@172: Eval compute in ExpDenote natOut_ns2. adamc@172: adamc@174: (* begin thide *) adamc@171: Section cfold. adamc@171: Variable var : type -> Type. adamc@171: adamc@172: Definition pairOutType t := adamc@204: match t return Type with adamc@172: | t1 ** t2 => option (exp var t1 * exp var t2) adamc@172: | _ => unit adamc@172: end. adamc@172: adamc@172: Definition pairOutDefault (t : type) : pairOutType t := adamc@172: match t return pairOutType t with adamc@172: | _ ** _ => None adamc@172: | _ => tt adamc@172: end. adamc@172: adamc@223: Definition pairOut t1 t2 (e : exp var (t1 ** t2)) adamc@223: : option (exp var t1 * exp var t2) := adamc@172: match e in exp _ t return pairOutType t with adamc@172: | Pair _ _ e1 e2 => Some (e1, e2) adamc@172: | _ => pairOutDefault _ adamc@172: end. adamc@172: adamc@223: Fixpoint cfold t (e : exp var t) : exp var t := adamc@223: match e with adamc@171: | Var _ v => #v adamc@171: adamc@171: | Const n => ^n adamc@171: | Plus e1 e2 => adamc@171: let e1' := cfold e1 in adamc@171: let e2' := cfold e2 in adamc@204: match e1', e2' return _ with adamc@171: | Const n1, Const n2 => ^(n1 + n2) adamc@171: | _, _ => e1' +^ e2' adamc@171: end adamc@171: adamc@171: | App _ _ e1 e2 => cfold e1 @ cfold e2 adamc@171: | Abs _ _ e' => Abs (fun x => cfold (e' x)) adamc@171: adamc@171: | Pair _ _ e1 e2 => [cfold e1, cfold e2] adamc@172: | Fst t1 _ e' => adamc@172: let e'' := cfold e' in adamc@172: match pairOut e'' with adamc@172: | None => #1 e'' adamc@172: | Some (e1, _) => e1 adamc@172: end adamc@172: | Snd _ _ e' => adamc@172: let e'' := cfold e' in adamc@172: match pairOut e'' with adamc@172: | None => #2 e'' adamc@172: | Some (_, e2) => e2 adamc@172: end adamc@171: adamc@171: | Inl _ _ e' => Inl (cfold e') adamc@171: | Inr _ _ e' => Inr (cfold e') adamc@171: | SumCase _ _ _ e' e1 e2 => adamc@171: case cfold e' of adamc@171: x => cfold (e1 x) adamc@171: | y => cfold (e2 y) adamc@171: end. adamc@171: End cfold. adamc@171: adamc@171: Definition Cfold t (E : Exp t) : Exp t := fun _ => cfold (E _). adamc@171: adamc@172: Section pairs. adamc@172: Variables A B : Type. adamc@172: adamc@172: Variable v1 : A. adamc@172: Variable v2 : B. adamc@172: Variable v : A * B. adamc@172: adamc@172: Theorem pair_eta1 : (v1, v2) = v -> v1 = fst v. adamc@172: destruct v; crush. adamc@172: Qed. adamc@172: adamc@172: Theorem pair_eta2 : (v1, v2) = v -> v2 = snd v. adamc@172: destruct v; crush. adamc@172: Qed. adamc@172: End pairs. adamc@172: adamc@172: Hint Resolve pair_eta1 pair_eta2. adamc@172: adamc@171: Lemma cfold_correct : forall t (e : exp _ t), adamc@171: expDenote (cfold e) = expDenote e. adamc@171: induction e; crush; try (ext_eq; crush); adamc@171: repeat (match goal with adamc@171: | [ |- context[cfold ?E] ] => dep_destruct (cfold E) adamc@171: | [ |- match ?E with inl _ => _ | inr _ => _ end = _ ] => destruct E adamc@172: end; crush); eauto. adamc@171: Qed. adamc@171: adamc@171: Theorem Cfold_correct : forall t (E : Exp t), adamc@171: ExpDenote (Cfold E) = ExpDenote E. adamc@171: unfold ExpDenote, Cfold; intros; apply cfold_correct. adamc@171: Qed. adamc@174: (* end thide *) adamc@171: End PSLC.