Type-directed memoization

Memo.hs

-- http://research.microsoft.com/en-us/um/people/simonpj/papers/assoc-types/fun-with-type-funs/typefun.pdf
{-# LANGUAGE TypeFamilies #-}

class Memo a where
  data Table a :: * -> *
  toTable :: (a -> w) -> Table a w
  fromTable :: Table a w -> (a -> w)

instance Memo Bool where
  data Table Bool w = TBool w w
  toTable f = TBool (f True) (f False)
  fromTable (TBool x y) b = if b then x else y

instance (Memo a, Memo b) => Memo (Either a b) where
  data Table (Either a b) w = TSum (Table a w) (Table b w)
  toTable f = TSum (toTable (f . Left)) (toTable (f . Right))
  fromTable (TSum t _) (Left v) = fromTable t v
  fromTable (TSum _ t) (Right v) = fromTable t v

instance (Memo a, Memo b) => Memo (a, b) where
  newtype Table (a, b) w = TProduct (Table a (Table b w))
  toTable f = TProduct (toTable (\x -> toTable (\y -> f (x, y))))
  fromTable (TProduct t) (x, y) = fromTable (fromTable t x) y

instance (Memo a) => Memo [a] where
  data Table [a] w = TList w (Table a (Table [a] w))
  toTable f = TList (f [])
                    (toTable (\x -> toTable (\xs -> f (x:xs))))
  fromTable (TList t _) [] = t
  fromTable (TList _ t) (x:xs) = fromTable (fromTable t x) xs

factorial 0 = 1
factorial n = n * factorial (n - 1)

fibonacci 0 = 1
fibonacci 1 = 1
fibonacci n = fibonacci (n -1) + fibonacci (n - 2)

f :: Bool -> Integer
f True = factorial 100
f False = fibonacci 30

g :: Bool -> Integer
g = fromTable (toTable f)