Require Import Program.Basics Program.Tactics.
Require Import Equations.Equations.
Require Import Coq.Vectors.VectorDef.
Require Import List.
Import ListNotations.
Set Equations Transparent.

Derive Signature NoConfusion NoConfusionHom for t.

Inductive Ty : Set :=
| unit : Ty
| arrow (t u : Ty) : Ty.

Derive NoConfusion for Ty.

Infix "⇒" := arrow (at level 80).

Definition Ctx := list Ty.

Reserved Notation " x ∈ s " (at level 70, s at level 10).

Inductive In {A} (x : A) : list AType :=
| here {xs} : x ∈ (x :: xs)
| there {y xs} : xxsx ∈ (y :: xs)
where " x ∈ s " := (In x s).

Arguments here {A x xs}.
Arguments there {A x y xs} _.

Inductive Expr : CtxTySet :=
| tt {Γ} : Expr Γ unit
| var {Γ} {t} : In t ΓExpr Γ t
| abs {Γ} {t u} : Expr (t :: Γ) uExpr Γ (tu)
| app {Γ} {t u} : Expr Γ (tu) → Expr Γ tExpr Γ u.

Derive Signature NoConfusion NoConfusionHom for Expr.

Inductive All {A} (P : AType) : list AType :=
| all_nil : All P []
| all_cons {x xs} : P xAll P xsAll P (x :: xs).
Arguments all_nil {A} {P}.
Arguments all_cons {A P x xs} _ _.
Derive Signature NoConfusion NoConfusionHom for All.

Section MapAll.
  Context {A} {P Q : AType} (f : x, P xQ x).

  Equations map_all {l : list A} : All P lAll Q l :=
  map_all all_nil := all_nil;
  map_all (all_cons p ps) := all_cons (f _ p) (map_all ps).
End MapAll.

Inductive Val : TySet :=
| val_unit : Val unit
| val_closure {Γ t u} : Expr (t :: Γ) uAll Val ΓVal (tu).

Derive Signature NoConfusion NoConfusionHom for Val.

Definition Env (Γ : Ctx) : Set := All Val Γ.

Equations lookup : {A P xs} {x : A}, All P xsxxsP x :=
  lookup (all_cons p _) here := p;
  lookup (all_cons _ ps) (there ins) := lookup ps ins.

Equations update : {A P xs} {x : A}, All P xsxxsP xAll P xs :=
  update (all_cons p ps) here p' := all_cons p' ps;
  update (all_cons p ps) (there ins) p' := all_cons p (update ps ins p').

Equations M : CtxTypeType :=
  M Γ A := Env Γoption A.

Require Import Utf8.

Equations bind : ∀ {Γ A B}, M Γ A → (AM Γ B) → M Γ B :=
  bind m f γ := match m γ with
              | NoneNone
              | Some xf x γ
              end.
Infix ">>=" := bind (at level 20, left associativity).

Equations ret : ∀ {Γ A}, AM Γ A :=
  ret a γ := Some a.

Equations getEnv : ∀ {Γ}, M Γ (Env Γ) :=
  getEnv γ := Some γ.

Equations usingEnv : ∀ {Γ Γ' A}, Env ΓM Γ AM Γ' A :=
  usingEnv γ m γ' := m γ.

Equations timeout : ∀ {Γ A}, M Γ A :=
  timeout _ := None.

Equations eval : ∀ (n : nat) {Γ t} (e : Expr Γ t), M Γ (Val t) :=
  eval 0 _ := timeout;
  eval (S k) tt := ret val_unit;
  eval (S k) (var x) := getEnv >>= fun Eret (lookup E x);
  eval (S k) (abs x) := getEnv >>= fun Eret (val_closure x E);
  eval (S k) (app (Γ:=Γ) f arg) := eval k f >>= (#{ | val_closure e' E
                                               eval k arg >>= fun a'usingEnv (all_cons a' E) (eval k e')}).

Inductive eval_sem {Γ : Ctx} {env : Env Γ} : {t : Ty}, Expr Γ tVal tProp :=
| eval_tt (e : Expr Γ unit) : eval_sem e val_unit
| eval_var t (i : tΓ) : eval_sem (var i) (lookup env i)
| eval_abs {t u} (b : Expr (t :: Γ) u) : eval_sem (abs b) (val_closure b env)
| eval_app {t u} (f : Expr Γ (tu)) b' (a : Expr Γ t) v :
    eval_sem f (val_closure b' env) →
    eval_sem a v
     u, @eval_sem (t :: Γ) (all_cons v env) _ b' u
    eval_sem (app f a) u.

Lemma eval_correct {n} Γ t (e : Expr Γ t) env v : eval n e env = Some v → @eval_sem _ env _ e v.
Proof.
  pose proof (fun_elim (f:=eval)).
  specialize (H (fun n Γ t e m env v, m env = Some v → @eval_sem _ env _ e v)
                (fun n Γ t u f a v m env v',
                     @eval_sem _ env _ f vm env = Some v' → @eval_sem _ env _ (app f a) v')).
  rapply H; clear; intros.
  discriminate.
  noconf H. constructor.
  noconf H. constructor.

  noconf H. constructor.

  unfold bind in H1.
  destruct (eval n e0 env) eqn:Heq.
  specialize (H _ _ Heq).
  specialize (H0 v0 _ _ H H1). apply H0.
  discriminate.

  (* Context mismatch *)
  unfold bind in H2.
  destruct (eval k arg env) eqn:Heq.
  specialize (H _ _ Heq).
  unfold usingEnv in H2. specialize (H0 v (all_cons v a) v').
  econstructor; eauto.
Admitted.

This page has been generated by coqdoc