A Tagless Interpreter

A favorite example for motivating the power of functional programming is implementation of a simple expression language interpreter. In ML and Haskell, such interpreters are often implemented using an algebraic datatype of values, where at many points it is checked that a value was built with the right constructor of the value type. With dependent types, we can implement a tagless interpreter that both removes this source of runtime inefficiency and gives us more confidence that our implementation is correct.

Inductive type : Set :=
| Nat : type
| Bool : type
| Prod : type -> type -> type.

Inductive exp : type -> Set :=
| NConst : nat -> exp Nat
| Plus : exp Nat -> exp Nat -> exp Nat
| Eq : exp Nat -> exp Nat -> exp Bool

| BConst : bool -> exp Bool
| And : exp Bool -> exp Bool -> exp Bool
| If : forall {t}, exp Bool -> exp t -> exp t -> exp t

| Pair : forall {t1 t2}, exp t1 -> exp t2 -> exp (Prod t1 t2)
| Fst : forall {t1 t2}, exp (Prod t1 t2) -> exp t1
| Snd : forall {t1 t2}, exp (Prod t1 t2) -> exp t2.

Here is a standard "tagged" interpreter

Inductive val : Type :=
  VNat : nat -> val
| VBool : bool -> val
| VPair : val -> val -> val.

Fixpoint tagDenote {t} (e:exp t) : option val :=
  match e with
  | NConst n =>
    Some (VNat n)
  | Plus e1 e2 =>
    match tagDenote e1, tagDenote e2 with
    | Some (VNat n1), Some (VNat n2) =>
                      Some (VNat (n1 + n2))
    | _,_ => None
    end
  | Eq e1 e2 => 
      match tagDenote e1, tagDenote e2 with
      | Some (VNat n1), Some (VNat n2) =>
                        Some (VBool (if PeanoNat.Nat.eq_dec n1 n2 then true else false))
      | _,_ => None
      end
  | BConst b => Some (VBool b)
  | And e1 e2 =>
    match tagDenote e1, tagDenote e2 with
    | Some (VBool b1), Some (VBool b2) =>
                       Some (VBool (andb b1 b2))
    | _,_ => None
    end
  | If e1 e2 e3 =>
    match tagDenote e1 with
    | Some (VBool b) =>
      if b then tagDenote e2 else tagDenote e3
    | _ => None
    end
  | Pair e1 e2 =>
      match tagDenote e1, tagDenote e2 with
      | Some v1, Some v2 =>
          Some (VPair v1 v2)
      | _,_ => None
      end 
  | Fst e =>
      match tagDenote e with
      | Some (VPair v1 v2) => Some v1
      | _ => None
      end
  | Snd e =>
      match tagDenote e with
      | Some (VPair v1 v2) => Some v2
      | _ => None
      end
  end.

We have a standard algebraic datatype type, defining a type language of naturals, Booleans, and product (pair) types. Then we have the indexed inductive type exp, where the argument to exp tells us the encoded type of an expression. In effect, we are defining the typing rules for expressions simultaneously with the syntax.

We can give types and expressions semantics in a new style, based critically on the chance for type-level computation.

Fixpoint typeDenote (t : type) : Set :=
  match t with
    | Nat => nat
    | Bool => bool
    | Prod t1 t2 => typeDenote t1 * typeDenote t2
  end%type.

The typeDenote function compiles types of our object language into "native" Coq types. It is deceptively easy to implement. The only new thing we see is the %type annotation, which tells Coq to parse the match expression using the notations associated with types. Without this annotation, the * would be interpreted as multiplication on naturals, rather than as the product type constructor. The token %type is one example of an identifier bound to a notation scope delimiter.

We can define a function expDenote that is typed in terms of typeDenote.

Fixpoint expDenote {t} (e : exp t) : typeDenote t :=
  match e in exp t return typeDenote t with
  | NConst n => n
  | Plus e1 e2 => expDenote e1 + expDenote e2
  | Eq e1 e2 =>
      if PeanoNat.Nat.eq_dec (expDenote e1) (expDenote e2)
      then true else false                       
  | BConst b => b
  | And e1 e2 => expDenote e1 && expDenote e2
  | If e' e1 e2 => if expDenote e' then expDenote e1 else expDenote e2                                                              
  | Pair e1 e2 => (expDenote e1, expDenote e2)
  | Fst e' => fst (expDenote e')
  | Snd e' => snd (expDenote e')
  end.

Despite the fancy type, the function definition is routine. In fact, it is less complicated than what we would write in ML or Haskell 98, since we do not need to worry about pushing final values in and out of an algebraic datatype. The only unusual thing is the use of an expression of the form if E then true else false in the Eq case. Remember that ==n has a rich dependent type, rather than a simple Boolean type. Coq's native if is overloaded to work on a test of any two-constructor type, so we can use if to build a simple Boolean from the sumbool that ==n returns.

We can implement our old favorite, a constant-folding function, and prove it correct. It will be useful to write a function pairOut that checks if an exp of Prod type is a pair, returning its two components if so. Unsurprisingly, a first attempt leads to a type error.

Fail Definition pairOut t1 t2
     (e : exp (Prod t1 t2)) : option (exp t1 * exp t2) :=
  match e in (exp (Prod t1 t2)) return option (exp t1 * exp t2) with
    | Pair e1 e2 => Some (e1, e2)
    | _ => None
  end.
The command has indeed failed with message:
In environment
t1 : type
t2 : type
e : exp (Prod t1 t2)
t : type
e0 : exp Bool
e1 : exp t
e2 : exp t
The term "None" has type "option ?A"
while it is expected to have type
 "match t as iV return (exp iV -> Type) with
  | Nat =>
      fun e3 : exp Nat =>
      option
        ?T@{e0:=e; iV:=t; e1:=If e0 e1 e2; e:=e3;
            e2:=e3}
  | Bool =>
      fun e3 : exp Bool =>
      option
        ?T0@{e0:=e; iV:=t; e1:=If e0 e1 e2; e:=e3;
             e2:=e3}
  | Prod t1 t2 =>
      fun _ : exp (Prod t1 t2) =>
      option (exp t1 * exp t2)
  end (If e0 e1 e2)".

We run again into the problem of not being able to specify non-variable arguments in in clauses (and this time Coq's avant-garde heuristics don't save us). The problem would just be hopeless without a use of an in clause, though, since the result type of the match depends on an argument to exp. Our solution will be to use a more general type, as we did for hd. First, we define a type-valued function to use in assigning a type to pairOut.

Definition pairOutType (t : type) :=
  option (match t with
          | Prod t1 t2 => exp t1 * exp t2
          | _ => unit
          end).

When passed a type that is a product, pairOutType returns our final desired type. On any other input type, pairOutType returns the harmless option unit, since we do not care about extracting components of non-pairs. Now pairOut is easy to write.

Definition pairOut {t} (e : exp t) :=
  match e in (exp t) return (pairOutType t) with
    | Pair e1 e2 => Some (e1, e2)
    | _ => None
  end.

With pairOut available, we can write cfold in a straightforward way. There are really no surprises beyond that Coq verifies that this code has such an expressive type, given the small annotation burden.

Fixpoint cfold {t} (e : exp t) : exp t :=
  match e with
  | NConst n => NConst n
  | Plus e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' with
      | NConst n1, NConst n2 => NConst (n1 + n2)
      | _, _ => Plus e1' e2'
      end
  | Eq e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' with
      | NConst n1, NConst n2 =>
          BConst (if PeanoNat.Nat.eq_dec n1 n2 then true else false)
      | _, _ => Eq e1' e2'
      end

  | BConst b => BConst b
  | And e1 e2 =>
      let e1' := cfold e1 in
      let e2' := cfold e2 in
      match e1', e2' with
      | BConst b1, BConst b2 => BConst (b1 && b2)
      | _, _ => And e1' e2'
      end
  | If e e1 e2 =>
      let e' := cfold e in
      match e' with
      | BConst true => cfold e1
      | BConst false => cfold e2
      | _ => If e' (cfold e1) (cfold e2)
      end

  | Pair e1 e2 => Pair (cfold e1) (cfold e2)
  | Fst e =>
      let e' := cfold e in
      match pairOut e' with
      | Some p => fst p
      | None => Fst e'
      end
  | Snd e =>
      let e' := cfold e in
      match pairOut e' with
      | Some p => snd p
      | None => Snd e'
      end
  end.

The correctness theorem for cfold turns out to be easy to prove, once we get over one serious hurdle.

Require Import Coq.Program.Equality.

Ltac dep_cases E :=
  let x := fresh "x" in
  remember E as x; simpl in x; dependent destruction x;
  try match goal with
      | [ H : _ = E |- _ ] => try rewrite <- H in *; clear H
      end.

Theorem cfold_correct :
  forall t (e : exp t), expDenote e = expDenote (cfold e).
forall (t : type) (e : exp t),
expDenote e = expDenote (cfold e)
Proof.
forall (t : type) (e : exp t),
expDenote e = expDenote (cfold e)
  induction e; simpl; try congruence.
e1, e2: exp Nat
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote
  match cfold e1 with
  | NConst n1 =>
      match cfold e2 with
      | NConst n2 => NConst (n1 + n2)
      | _ => Plus (cfold e1) (cfold e2)
      end
  | _ => Plus (cfold e1) (cfold e2)
  end
e1, e2: exp Nat
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
(if PeanoNat.Nat.eq_dec (expDenote e1) (expDenote e2)
 then true
 else false) =
expDenote
  match cfold e1 with
  | NConst n1 =>
      match cfold e2 with
      | NConst n2 =>
          BConst
            (if PeanoNat.Nat.eq_dec n1 n2
             then true
             else false)
      | _ => Eq (cfold e1) (cfold e2)
      end
  | _ => Eq (cfold e1) (cfold e2)
  end
e1, e2: exp Bool
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 && expDenote e2 =
expDenote
  match cfold e1 with
  | BConst b1 =>
      match cfold e2 with
      | BConst b2 => BConst (b1 && b2)
      | _ => And (cfold e1) (cfold e2)
      end
  | _ => And (cfold e1) (cfold e2)
  end
t: type
e1: exp Bool
e2, e3: exp t
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
IHe3: expDenote e3 = expDenote (cfold e3)
(if expDenote e1 then expDenote e2 else expDenote e3) =
expDenote
  match cfold e1 with
  | BConst true => cfold e2
  | BConst false => cfold e3
  | _ => If (cfold e1) (cfold e2) (cfold e3)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
fst (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => fst p
  | None => Fst (cfold e)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
snd (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => snd p
  | None => Snd (cfold e)
  end

We would like to do a case analysis on cfold e1, and we attempt to do so in the way that has worked so far.

 Fail destruct (cfold e1).
The command has indeed failed with message:
Abstracting over the terms "t" and "e" leads to a term
fun (t0 : type) (e0 : exp t0) =>
forall e3 e4 : exp t0,
expDenote e3 = expDenote e0 ->
expDenote e4 = expDenote (cfold e4) ->
expDenote e3 + expDenote e4 =
expDenote
  match e0 with
  | NConst n1 =>
      match cfold e4 with
      | NConst n2 => NConst (n1 + n2)
      | _ => Plus e0 (cfold e4)
      end
  | _ => Plus e0 (cfold e4)
  end
which is ill-typed.
Reason is: Illegal application: 
The term "Nat.add" of type "nat -> nat -> nat"
cannot be applied to the terms
 "expDenote e3" : "typeDenote t0"
 "expDenote e4" : "typeDenote t0"
The 1st term has type "typeDenote t0"
which should be a subtype of "nat".
e1, e2: exp Nat
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote
  match cfold e1 with
  | NConst n1 =>
      match cfold e2 with
      | NConst n2 => NConst (n1 + n2)
      | _ => Plus (cfold e1) (cfold e2)
      end
  | _ => Plus (cfold e1) (cfold e2)
  end
e1, e2: exp Nat
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
(if PeanoNat.Nat.eq_dec (expDenote e1) (expDenote e2)
 then true
 else false) =
expDenote
  match cfold e1 with
  | NConst n1 =>
      match cfold e2 with
      | NConst n2 =>
          BConst
            (if PeanoNat.Nat.eq_dec n1 n2
             then true
             else false)
      | _ => Eq (cfold e1) (cfold e2)
      end
  | _ => Eq (cfold e1) (cfold e2)
  end
e1, e2: exp Bool
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 && expDenote e2 =
expDenote
  match cfold e1 with
  | BConst b1 =>
      match cfold e2 with
      | BConst b2 => BConst (b1 && b2)
      | _ => And (cfold e1) (cfold e2)
      end
  | _ => And (cfold e1) (cfold e2)
  end
t: type
e1: exp Bool
e2, e3: exp t
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
IHe3: expDenote e3 = expDenote (cfold e3)
(if expDenote e1 then expDenote e2 else expDenote e3) =
expDenote
  match cfold e1 with
  | BConst true => cfold e2
  | BConst false => cfold e3
  | _ => If (cfold e1) (cfold e2) (cfold e3)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
fst (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => fst p
  | None => Fst (cfold e)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
snd (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => snd p
  | None => Snd (cfold e)
  end

A nasty error message greets us!

 dep_cases (cfold e1).
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote
  match cfold e2 with
  | NConst n2 => NConst (n + n2)
  | _ => Plus (NConst n) (cfold e2)
  end
e1, e2, x1, x2: exp Nat
IHe1: expDenote e1 = expDenote (Plus x1 x2)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Plus x1 x2) (cfold e2))
e1, e2: exp Nat
x1: exp Bool
x2, x3: exp Nat
IHe1: expDenote e1 = expDenote (If x1 x2 x3)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (If x1 x2 x3) (cfold e2))
e1, e2: exp Nat
t2: type
x: exp (Prod Nat t2)
IHe1: expDenote e1 = expDenote (Fst x)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Fst x) (cfold e2))
e1, e2: exp Nat
t1: type
x: exp (Prod t1 Nat)
IHe1: expDenote e1 = expDenote (Snd x)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Snd x) (cfold e2))
e1, e2: exp Nat
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
(if PeanoNat.Nat.eq_dec (expDenote e1) (expDenote e2)
 then true
 else false) =
expDenote
  match cfold e1 with
  | NConst n1 =>
      match cfold e2 with
      | NConst n2 =>
          BConst
            (if PeanoNat.Nat.eq_dec n1 n2
             then true
             else false)
      | _ => Eq (cfold e1) (cfold e2)
      end
  | _ => Eq (cfold e1) (cfold e2)
  end
e1, e2: exp Bool
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 && expDenote e2 =
expDenote
  match cfold e1 with
  | BConst b1 =>
      match cfold e2 with
      | BConst b2 => BConst (b1 && b2)
      | _ => And (cfold e1) (cfold e2)
      end
  | _ => And (cfold e1) (cfold e2)
  end
t: type
e1: exp Bool
e2, e3: exp t
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
IHe3: expDenote e3 = expDenote (cfold e3)
(if expDenote e1 then expDenote e2 else expDenote e3) =
expDenote
  match cfold e1 with
  | BConst true => cfold e2
  | BConst false => cfold e3
  | _ => If (cfold e1) (cfold e2) (cfold e3)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
fst (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => fst p
  | None => Fst (cfold e)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
snd (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => snd p
  | None => Snd (cfold e)
  end
 dep_cases (cfold e2).
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
n0: nat
IHe2: expDenote e2 = expDenote (NConst n0)
expDenote e1 + expDenote e2 =
expDenote (NConst (n + n0))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
x1, x2: exp Nat
IHe2: expDenote e2 = expDenote (Plus x1 x2)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (Plus x1 x2))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
x1: exp Bool
x2, x3: exp Nat
IHe2: expDenote e2 = expDenote (If x1 x2 x3)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (If x1 x2 x3))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
t2: type
x: exp (Prod Nat t2)
IHe2: expDenote e2 = expDenote (Fst x)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (Fst x))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
t1: type
x: exp (Prod t1 Nat)
IHe2: expDenote e2 = expDenote (Snd x)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (Snd x))
e1, e2, x1, x2: exp Nat
IHe1: expDenote e1 = expDenote (Plus x1 x2)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Plus x1 x2) (cfold e2))
e1, e2: exp Nat
x1: exp Bool
x2, x3: exp Nat
IHe1: expDenote e1 = expDenote (If x1 x2 x3)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (If x1 x2 x3) (cfold e2))
e1, e2: exp Nat
t2: type
x: exp (Prod Nat t2)
IHe1: expDenote e1 = expDenote (Fst x)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Fst x) (cfold e2))
e1, e2: exp Nat
t1: type
x: exp (Prod t1 Nat)
IHe1: expDenote e1 = expDenote (Snd x)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Snd x) (cfold e2))
e1, e2: exp Nat
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
(if PeanoNat.Nat.eq_dec (expDenote e1) (expDenote e2)
 then true
 else false) =
expDenote
  match cfold e1 with
  | NConst n1 =>
      match cfold e2 with
      | NConst n2 =>
          BConst
            (if PeanoNat.Nat.eq_dec n1 n2
             then true
             else false)
      | _ => Eq (cfold e1) (cfold e2)
      end
  | _ => Eq (cfold e1) (cfold e2)
  end
e1, e2: exp Bool
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 && expDenote e2 =
expDenote
  match cfold e1 with
  | BConst b1 =>
      match cfold e2 with
      | BConst b2 => BConst (b1 && b2)
      | _ => And (cfold e1) (cfold e2)
      end
  | _ => And (cfold e1) (cfold e2)
  end
t: type
e1: exp Bool
e2, e3: exp t
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
IHe3: expDenote e3 = expDenote (cfold e3)
(if expDenote e1 then expDenote e2 else expDenote e3) =
expDenote
  match cfold e1 with
  | BConst true => cfold e2
  | BConst false => cfold e3
  | _ => If (cfold e1) (cfold e2) (cfold e3)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
fst (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => fst p
  | None => Fst (cfold e)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
snd (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => snd p
  | None => Snd (cfold e)
  end
 rewrite IHe1.
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
n0: nat
IHe2: expDenote e2 = expDenote (NConst n0)
expDenote (NConst n) + expDenote e2 =
expDenote (NConst (n + n0))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
x1, x2: exp Nat
IHe2: expDenote e2 = expDenote (Plus x1 x2)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (Plus x1 x2))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
x1: exp Bool
x2, x3: exp Nat
IHe2: expDenote e2 = expDenote (If x1 x2 x3)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (If x1 x2 x3))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
t2: type
x: exp (Prod Nat t2)
IHe2: expDenote e2 = expDenote (Fst x)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (Fst x))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
t1: type
x: exp (Prod t1 Nat)
IHe2: expDenote e2 = expDenote (Snd x)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (Snd x))
e1, e2, x1, x2: exp Nat
IHe1: expDenote e1 = expDenote (Plus x1 x2)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Plus x1 x2) (cfold e2))
e1, e2: exp Nat
x1: exp Bool
x2, x3: exp Nat
IHe1: expDenote e1 = expDenote (If x1 x2 x3)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (If x1 x2 x3) (cfold e2))
e1, e2: exp Nat
t2: type
x: exp (Prod Nat t2)
IHe1: expDenote e1 = expDenote (Fst x)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Fst x) (cfold e2))
e1, e2: exp Nat
t1: type
x: exp (Prod t1 Nat)
IHe1: expDenote e1 = expDenote (Snd x)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Snd x) (cfold e2))
e1, e2: exp Nat
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
(if PeanoNat.Nat.eq_dec (expDenote e1) (expDenote e2)
 then true
 else false) =
expDenote
  match cfold e1 with
  | NConst n1 =>
      match cfold e2 with
      | NConst n2 =>
          BConst
            (if PeanoNat.Nat.eq_dec n1 n2
             then true
             else false)
      | _ => Eq (cfold e1) (cfold e2)
      end
  | _ => Eq (cfold e1) (cfold e2)
  end
e1, e2: exp Bool
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 && expDenote e2 =
expDenote
  match cfold e1 with
  | BConst b1 =>
      match cfold e2 with
      | BConst b2 => BConst (b1 && b2)
      | _ => And (cfold e1) (cfold e2)
      end
  | _ => And (cfold e1) (cfold e2)
  end
t: type
e1: exp Bool
e2, e3: exp t
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
IHe3: expDenote e3 = expDenote (cfold e3)
(if expDenote e1 then expDenote e2 else expDenote e3) =
expDenote
  match cfold e1 with
  | BConst true => cfold e2
  | BConst false => cfold e3
  | _ => If (cfold e1) (cfold e2) (cfold e3)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
fst (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => fst p
  | None => Fst (cfold e)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
snd (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => snd p
  | None => Snd (cfold e)
  end
 rewrite IHe2.
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
n0: nat
IHe2: expDenote e2 = expDenote (NConst n0)
expDenote (NConst n) + expDenote (NConst n0) =
expDenote (NConst (n + n0))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
x1, x2: exp Nat
IHe2: expDenote e2 = expDenote (Plus x1 x2)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (Plus x1 x2))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
x1: exp Bool
x2, x3: exp Nat
IHe2: expDenote e2 = expDenote (If x1 x2 x3)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (If x1 x2 x3))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
t2: type
x: exp (Prod Nat t2)
IHe2: expDenote e2 = expDenote (Fst x)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (Fst x))
e1, e2: exp Nat
n: nat
IHe1: expDenote e1 = expDenote (NConst n)
t1: type
x: exp (Prod t1 Nat)
IHe2: expDenote e2 = expDenote (Snd x)
expDenote e1 + expDenote e2 =
expDenote (Plus (NConst n) (Snd x))
e1, e2, x1, x2: exp Nat
IHe1: expDenote e1 = expDenote (Plus x1 x2)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Plus x1 x2) (cfold e2))
e1, e2: exp Nat
x1: exp Bool
x2, x3: exp Nat
IHe1: expDenote e1 = expDenote (If x1 x2 x3)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (If x1 x2 x3) (cfold e2))
e1, e2: exp Nat
t2: type
x: exp (Prod Nat t2)
IHe1: expDenote e1 = expDenote (Fst x)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Fst x) (cfold e2))
e1, e2: exp Nat
t1: type
x: exp (Prod t1 Nat)
IHe1: expDenote e1 = expDenote (Snd x)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 + expDenote e2 =
expDenote (Plus (Snd x) (cfold e2))
e1, e2: exp Nat
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
(if PeanoNat.Nat.eq_dec (expDenote e1) (expDenote e2)
 then true
 else false) =
expDenote
  match cfold e1 with
  | NConst n1 =>
      match cfold e2 with
      | NConst n2 =>
          BConst
            (if PeanoNat.Nat.eq_dec n1 n2
             then true
             else false)
      | _ => Eq (cfold e1) (cfold e2)
      end
  | _ => Eq (cfold e1) (cfold e2)
  end
e1, e2: exp Bool
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
expDenote e1 && expDenote e2 =
expDenote
  match cfold e1 with
  | BConst b1 =>
      match cfold e2 with
      | BConst b2 => BConst (b1 && b2)
      | _ => And (cfold e1) (cfold e2)
      end
  | _ => And (cfold e1) (cfold e2)
  end
t: type
e1: exp Bool
e2, e3: exp t
IHe1: expDenote e1 = expDenote (cfold e1)
IHe2: expDenote e2 = expDenote (cfold e2)
IHe3: expDenote e3 = expDenote (cfold e3)
(if expDenote e1 then expDenote e2 else expDenote e3) =
expDenote
  match cfold e1 with
  | BConst true => cfold e2
  | BConst false => cfold e3
  | _ => If (cfold e1) (cfold e2) (cfold e3)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
fst (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => fst p
  | None => Fst (cfold e)
  end
t1, t2: type
e: exp (Prod t1 t2)
IHe: expDenote e = expDenote (cfold e)
snd (expDenote e) =
expDenote
  match pairOut (cfold e) with
  | Some p => snd p
  | None => Snd (cfold e)
  end

Incidentally, general and fully precise case analysis on dependently typed variables is undecidable, as witnessed by a simple reduction from the known-undecidable problem of higher-order unification. The tactic dep_cases makes a best effort to handle some common cases.

This successfully breaks the subgoal into 5 new subgoals, one for each constructor of exp that could produce an exp Nat. Note that dep_cases is successful in ruling out the other cases automatically, in effect automating some of the work that we have done manually in implementing functions like hd and pairOut.

This is the only new trick we need to learn to complete the proof. We can back up and give a short, automated proof.

  Restart.
forall (t : type) (e : exp t),
expDenote e = expDenote (cfold e)

  induction e; simpl;
    repeat
      (match goal with
       | [ |- context[match cfold ?E
                     with NConst _ => _ | _ => _ end] ] =>
           dep_cases (cfold E)
       | [ |- context[match pairOut (cfold ?E) with
                     | Some _ => _
                     | None => _ end] ] =>
           dep_cases (cfold E)
       | [ |- context[if ?E then _ else _] ] => destruct E
       | [ H : _ = _ |- _ ] => rewrite H
       end; simpl in *); congruence.
Qed.