Library Exn

Require Import Eqdep.
Require Import String.
Require Import List.
Require Import Bool.
Require Import Omega.
Require Import Recdef.
Set Implicit Arguments.
Unset Automatic Introduction.
Local Open Scope string_scope.

Definition var := string.
Definition env(A:Type) := list (var * A).
Fixpoint lookup A (env:env A) (x:var) : option A :=
  match env with
    | nil => None
    | (y,v)::env' => if string_dec x y then Some v else lookup env' x
  end.

This module demonstrates a simple, stack-based machine for handling exceptions.
Module EXN_MACHINE.

Intuitively, Try_e e1 e2 executes e1 and if it terminates normally with a value v, then the e2 is ignored and the value v is returned as the result. If during execution, we perform a Raise_e, then the exception is caught by the nearest (dynamically) enclosing Try_e e1 e2, and e2 is executed as a "handler".
  Inductive exp : Type :=
  | Var_e : var -> exp
  | Lam_e : var -> exp -> exp
  | App_e : exp -> exp -> exp
  | Unit_e : exp
  | Pair_e : exp -> exp -> exp
  | Fst_e : exp -> exp
  | Snd_e : exp -> exp
  | Raise_e : exp
  | Try_e : exp -> exp -> exp.

It's useful to distinguish values and expressions.
  Inductive value : Type :=
  | Lam_v : var -> exp -> value
  | Unit_v : value
  | Pair_v : value -> value -> value.

But since I'm going to use a substitution-based machine, I need some way to convert values back to expressions.
  Fixpoint value2exp(v:value) : exp :=
    match v with
      | Lam_v x e => Lam_e x e
      | Unit_v => Unit_e
      | Pair_v v1 v2 => Pair_e (value2exp v1) (value2exp v2)
    end.

  Fixpoint subst (v:value) (x:var) (e:exp) : exp :=
    match e with
      | Var_e y as e => if string_dec x y then value2exp v else e
      | Lam_e y e' as e => if string_dec x y then e else Lam_e y (subst v x e')
      | App_e e1 e2 => App_e (subst v x e1) (subst v x e2)
      | Unit_e => Unit_e
      | Pair_e e1 e2 => Pair_e (subst v x e1) (subst v x e2)
      | Fst_e e => Fst_e (subst v x e)
      | Snd_e e => Snd_e (subst v x e)
      | Raise_e => Raise_e
      | Try_e e1 e2 => Try_e (subst v x e1) (subst v x e2)
    end.

Definition of the machine parts: The machine contains a stack and control. The control just indicates what expression we are evaluating, or what value we are returning. The stack is a list of frames, and the frames determine what to do once we've evaluated an expression down to a value (or when we have a Raise_e.)
  Inductive control :=
  | Exp : exp -> control
  | Val : value -> control.

  Inductive frame : Type :=
  | AppLeft_f : exp -> frame
  | AppRight_f : value -> frame
  | PairLeft_f : exp -> frame
  | PairRight_f : value -> frame
  | Fst_f : frame
  | Snd_f : frame
  | Try_f : exp -> frame.

  Definition stack := list frame.

  Definition machine := (stack * control)%type.

Our step relation for machines -- notice no recursion, so a loop that iterates step would be tail-recursive. The rules are largely grouped by operation: When we have a compund expression, we push an appropriate frame on the stack, and execute the sub-expression. As sub-expressions are evaluated down to values, we adjust the top-stack frame, short- circuiting the process of popping a frame, filling it with the value, and then finding the next redex.

The interesting cases are the ones for Try_e and Raise_e. Notice that Raise_e stops when we get to the nearest enclosing Try_e but otherwise, just pops frames off the stack.

Finally, note that we can take advantage of the exhaustivness checking to ensure that we've covered all of the cases --- something we wouldn't be able to do with an inductive definition.

Of course, if we decided to make the machine non-deterministic, then it might seem natural to use a relation instead of a function. But if the branching factor is finite (i.e., there is a finite set of possible steps we might take from a given machine state), then we could always represent this as a function from the machine state to the sets of possible machine states.
  Definition step (m:machine) : option machine :=
    match m with
      | (s, Exp (Var_e _)) => None
        
      | (s, Exp (Lam_e x e)) => Some (s, Val (Lam_v x e))
        
      | (s, Exp (App_e e1 e2)) => Some ((AppLeft_f e2)::s, Exp e1)
      | ((AppLeft_f e2)::s, Val v1) => Some ((AppRight_f v1)::s, Exp e2)
      | ((AppRight_f (Lam_v x e))::s, Val v2) => Some (s, Exp (subst v2 x e))
      | ((AppRight_f _)::s, Val v2) => None

      | (s, Exp Unit_e) => Some (s, Val Unit_v)
        
      | (s, Exp (Pair_e e1 e2)) => Some ((PairLeft_f e2)::s, Exp e1)
      | ((PairLeft_f e2)::s, Val v1) => Some ((PairRight_f v1)::s, Exp e2)
      | ((PairRight_f v1)::s, Val v2) => Some (s, Val (Pair_v v1 v2))
        
      | (s, Exp (Fst_e e)) => Some (Fst_f::s, Exp e)
      | (Fst_f::s, Val (Pair_v v1 v2)) => Some (s, Val v1)
      | (Fst_f::s, Val _) => None
      
      | (s, Exp (Snd_e e)) => Some (Snd_f::s, Exp e)
      | (snd_f::s, Val (Pair_v v1 v2)) => Some (s, Val v2)
      | (Snd_f::s, Val _) => None

      | (s, Exp (Try_e e1 e2)) => Some ((Try_f e2)::s, Exp e1)
      | ((Try_f _)::s, Val v) => Some (s, Val v)
      | ((Try_f e2)::s, Exp Raise_e) => Some (s, Exp e2)
      | (F::s, Exp Raise_e) => Some (s, Exp Raise_e)
        
      | (nil, Val v) => None
      | (nil, Exp Raise_e) => None
  end.
End EXN_MACHINE.

Module TYPED_EXN.
  Inductive type : Type :=
  | Unit_t : type
  | Arrow_t : type -> type -> type
  | Pair_t : type -> type -> type.

  Inductive exp : env type -> type -> Type :=
  | Var_e : forall G t x, lookup G x = Some t -> exp G t
  | Lam_e : forall G t1 t2 x (e:exp ((x,t1)::G) t2), exp G (Arrow_t t1 t2)
  | App_e : forall G t1 t2, exp G (Arrow_t t1 t2) -> exp G t1 -> exp G t2
  | Unit_e : forall G, exp G Unit_t
  | Pair_e : forall G t1 t2, exp G t1 -> exp G t2 -> exp G (Pair_t t1 t2)
  | Fst_e : forall G t1 t2, exp G (Pair_t t1 t2) -> exp G t1
  | Snd_e : forall G t1 t2, exp G (Pair_t t1 t2) -> exp G t2
  | Try_e : forall G t, exp G t -> exp G t -> exp G t
  | Raise_e : forall G t, exp G t.
End TYPED_EXN.

Here we give a denotational semantics, treating computations as something that returns an optional value.
Module EXN_DENOTE.
  Import TYPED_EXN.
  Definition M (A:Type) := option A.
  Definition Ret{A:Type}(v:A) : M A := Some v.
  Definition Raise(A:Type) : M A := None.
  Definition Bind{A B:Type}(c:M A)(f:A -> M B) : M B :=
    match c with
      | None => None
      | Some v => f v
    end.
  Definition Try{A}(c1:M A)(c2:M A) : M A :=
    match c1 with
      | None => c2
      | Some v => Some v
    end.
  Notation "'ret' x" := (Ret x) (at level 75).
  Notation "x <- c ; f" := (Bind c (fun x => f))
    (right associativity, at level 84, c at next level).

  Fixpoint V (t:type) : Type :=
    match t with
      | Unit_t => unit
      | Arrow_t t1 t2 => V t1 -> M (V t2)
      | Pair_t t1 t2 => (V t1) * (V t2)
    end %type.

  Definition C (t:type) := M (V t).

  Fixpoint VG (G:env type) : Type :=
    match G with
      | nil => unit
      | h::t => V (snd h) * VG t
    end %type.

  Definition lookup_var G (dynenv : VG G) (x:var) (t:type) : (lookup G x = Some t) -> V t.
    induction G ; simpl. intros. discriminate H.
    intros. destruct a. destruct dynenv.
    destruct (string_dec x v). injection H. intro.
    rewrite H0 in v0. apply v0. apply (IHG v1 _ _ H).
  Defined.

  Fixpoint eval G t (e:exp G t) : VG G -> C t :=
    match e in exp G' t' return VG G' -> C t' with
      | Var_e G t x H => fun p => ret lookup_var G p x H
      | Lam_e _ _ _ x e => fun p => ret fun v => eval e (v,p)
      | App_e _ _ _ e1 e2 => fun p =>
        v1 <- eval e1 p ; v2 <- eval e2 p ; v1 v2
      | Unit_e _ => fun p => ret tt
      | Pair_e _ _ _ e1 e2 => fun p => v1 <- eval e1 p ; v2 <- eval e2 p ; ret (v1,v2)
      | Fst_e _ _ _ e => fun p => v <- eval e p ; ret fst v
      | Snd_e _ _ _ e => fun p => v <- eval e p ; ret snd v
      | Raise_e _ _ => fun p => Raise _
      | Try_e _ _ e1 e2 => fun p =>
        Try (eval e1 p) (eval e2 p)
    end.

  Definition evaluate t (e:exp nil t) : C t := eval e tt.
End EXN_DENOTE.

This is an alternative semantics based on continuation-passing style. However, note that we use two continuations, one for success, and one for failure, which avoids the need to "unwind" the stack of continuations or do intermediate pattern matching (at the price of duplicating some continuations.)
Module EXN_DENOTE_CPS.
  Import TYPED_EXN.
  Section ANS.
    Variable ans : Type.
    Definition M (A : Type) := (A -> ans) -> ans -> ans.
    Definition Ret{A:Type}(v:A) : M A := fun sk fk => sk v.
    Definition Raise(A:Type) : M A := fun sk fk => fk.
    Definition Bind{A B:Type}(c:M A)(f:A -> M B) : M B :=
      fun sk fk => c (fun v => f v sk fk) fk.
    Definition Try{A}(c1:M A)(c2:M A) : M A :=
      fun sk fk => c1 sk (c2 sk fk).
    Notation "'ret' x" := (Ret x) (at level 75).
    Notation "x <- c ; f" := (Bind c (fun x => f))
      (right associativity, at level 84, c at next level).

    Fixpoint V (t:type) : Type :=
      match t with
        | Unit_t => unit
        | Pair_t t1 t2 => (V t1) * (V t2)
        | Arrow_t t1 t2 => V t1 -> M (V t2)
      end %type.

    Definition C (t:type) := M (V t).

    Fixpoint VG (G:env type) : Type :=
      match G with
        | nil => unit
        | h::t => V (snd h) * VG t
      end %type.

    Definition lookup_var G (dynenv : VG G) (x:var) (t:type) : (lookup G x = Some t) -> V t.
      induction G ; simpl. intros. discriminate H.
      intros. destruct a. destruct dynenv.
      destruct (string_dec x v). injection H. intro.
      rewrite H0 in v0. apply v0. apply (IHG v1 _ _ H).
    Defined.

    Fixpoint eval G t (e:exp G t) : VG G -> C t :=
      match e in exp G' t' return VG G' -> C t' with
        | Var_e G t x H => fun p => ret lookup_var G p x H
        | Lam_e _ _ _ x e => fun p => ret fun v => eval e (v,p)
        | App_e _ _ _ e1 e2 => fun p =>
          v1 <- eval e1 p ; v2 <- eval e2 p ; v1 v2
        | Unit_e _ => fun p => ret tt
        | Pair_e _ _ _ e1 e2 => fun p => v1 <- eval e1 p ; v2 <- eval e2 p ; ret (v1,v2)
        | Fst_e _ _ _ e => fun p => v <- eval e p ; ret fst v
        | Snd_e _ _ _ e => fun p => v <- eval e p ; ret snd v
        | Raise_e _ t => fun p => @Raise _
        | Try_e _ _ e1 e2 => fun p =>
          Try (eval e1 p) (eval e2 p)
      end.
  End ANS.

  Definition evaluate (e : exp nil Unit_t) : (option unit) :=
    eval e tt (fun (v:V (option unit) Unit_t) => Some v) None.

End EXN_DENOTE_CPS.