Question

GHC 7.6.1 comes with new features for programming at the type level, including datatype promotion. Taking the example about type-level naturals and vectors from there, I’d like to be able to write functions on vectors that rely on basic laws of arithmetic.

Unfortunately, even though the laws I want are typically easy to prove on inductive naturals by case analysis and induction, I’m doubt I can convince the type-checker of this. As a simple example, type-checking the naive reverse function below requires a proof that n + Su Ze ~ Su n.

Is there any way I can supply that proof, or am I really in the realm of full-blown dependent types now?

{-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies, TypeOperators #-}

data Nat = Ze | Su Nat

data Vec :: * -> Nat -> * where
  Nil  :: Vec a Ze
  Cons :: a -> Vec a n -> Vec a (Su n)

type family (m :: Nat) + (n :: Nat) :: Nat

type instance Ze + n = n
type instance (Su m + n) = Su (m + n)

append :: Vec a m -> Vec a n -> Vec a (m + n)
append Nil ys = ys
append (Cons x xs) ys = Cons x (append xs ys)

rev :: Vec a n -> Vec a n
rev Nil = Nil
rev (Cons x xs) = rev xs `append` Cons x Nil

Answer 1

(Note: I have only type-checked (and not actually run) any of this code.)

Approach 1

Actually, you can manipulate proofs by storing them in GADTs. You’ll need to turn on ScopedTypeVariables for this approach to work.

data Proof n where
    NilProof  :: Proof Ze
    ConsProof :: (n + Su Ze) ~ Su n => Proof n -> Proof (Su n)

class PlusOneIsSucc n where proof :: Proof n
instance PlusOneIsSucc Ze where proof = NilProof
instance PlusOneIsSucc n => PlusOneIsSucc (Su n) where
    proof = case proof :: Proof n of
        NilProof    -> ConsProof proof
        ConsProof _ -> ConsProof proof

rev :: PlusOneIsSucc n => Vec a n -> Vec a n
rev = go proof where
    go :: Proof n -> Vec a n -> Vec a n
    go NilProof Nil = Nil
    go (ConsProof p) (Cons x xs) = go p xs `append` Cons x Nil

Actually, perhaps interesting motivation for the Proof type above, I originally had just

data Proof n where Proof :: (n + Su Ze) ~ Su n => Proof n

But, this didn’t work: GHC rightly complained that just because we know (Su n)+1 = Su (Su n) doesn’t imply that we know n+1 = Su n, which is what we need to know to make the recursive call to rev in the Cons case. So I had to expand the meaning of a Proof to include a proof of all equalities for naturals up to and including n — essentially a similar thing to the strengthening process when moving from induction to strong induction.

Approach 2

After a bit of reflection, I realized that it turns out the class is a bit superfluous; that makes this approach especially nice in that it doesn’t require any extra extensions (even ScopedTypeVariables) and doesn’t introduce any extra constraints to the type of Vec.

data Proof n where
    NilProof  :: Proof Ze
    ConsProof :: (n + Su Ze) ~ Su n => Proof n -> Proof (Su n)

proofFor :: Vec a n -> Proof n
proofFor Nil = NilProof
proofFor (Cons x xs) = let rec = proofFor xs in case rec of
    NilProof    -> ConsProof rec
    ConsProof _ -> ConsProof rec

rev :: Vec a n -> Vec a n
rev xs = go (proofFor xs) xs where
    go :: Proof n -> Vec a n -> Vec a n
    go NilProof Nil = Nil
    go (ConsProof p) (Cons x xs) = go p xs `append` Cons x Nil

Approach 3

Alternately, if you switch the implementation of rev a bit to cons the last element onto the reversed initial segment of the list, then the code can look a bit more straightforward. (This approach also requires no additional extensions.)

class Rev n where
    initLast :: Vec a (Su n) -> (a, Vec a n)
    rev :: Vec a n -> Vec a n

instance Rev Ze where
    initLast (Cons x xs) = (x, xs)
    rev x = x

instance Rev n => Rev (Su n) where
    initLast (Cons x xs) = case initLast xs of
        (x', xs') -> (x', Cons x xs')
    rev as = case initLast as of
        (a, as') -> Cons a (rev as')

Approach 4

Just like approach 3, but again observing that the type classes are not necessary.

initLast :: Vec a (Su n) -> (a, Vec a n)
initLast (Cons x xs) = case xs of
    Nil     -> (x, Nil)
    Cons {} -> case initLast xs of
        (x', xs') -> (x', Cons x xs')

rev :: Vec a n -> Vec a n
rev Nil = Nil
rev xs@(Cons {}) = case initLast xs of
    (x, xs') -> Cons x (rev xs')