Defining arity-generic lift

Question

I'm trying to define liftN for Haskell. The value-level implementation in dynamically typed languages like JS is fairly straightforward, I'm just having trouble expressing it in Haskell.

After some trial and error, I arrived at the following, which typechecks (note the entire implementation of liftN is undefined):

{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}

import Data.Proxy
import GHC.TypeLits

type family Fn x (y :: [*]) where
  Fn x '[]    = x
  Fn x (y:ys) = x -> Fn y ys

type family Map (f :: * -> *) (x :: [*]) where
  Map f '[]     = '[]
  Map f (x:xs)  = (f x):(Map f xs)

type family LiftN (f :: * -> *) (x :: [*]) where
  LiftN f (x:xs)  = (Fn x xs) -> (Fn (f x) (Map f xs))

liftN :: Proxy x -> LiftN f x
liftN = undefined

This gives me the desired behavior in ghci:

*Main> :t liftN (Proxy :: Proxy '[a])
liftN (Proxy :: Proxy '[a]) :: a -> f a

*Main> :t liftN (Proxy :: Proxy '[a, b])
liftN (Proxy :: Proxy '[a, b]) :: (a -> b) -> f a -> f b

and so on.

The part I'm stumped on is how to actually implement it. I was figuring maybe the easiest way is to exchange the type level list for a type level number representing its length, use natVal to get the corresponding value level number, and then dispatch 1 to pure, 2 to map and n to (finally), the actual recursive implementation of liftN.

Unfortunately I can't even get the pure and map cases to typecheck. Here's what I added (note go is still undefined):

type family Length (x :: [*]) where
  Length '[]    = 0
  Length (x:xs) = 1 + (Length xs)

liftN :: (KnownNat (Length x)) => Proxy x -> LiftN f x
liftN (Proxy :: Proxy x) = go (natVal (Proxy :: Proxy (Length x))) where
  go = undefined

So far so good. But then:

liftN :: (Applicative f, KnownNat (Length x)) => Proxy x -> LiftN f x
liftN (Proxy :: Proxy x) = go (natVal (Proxy :: Proxy (Length x))) where
  go 1 = pure
  go 2 = fmap
  go n = undefined

...disaster strikes:

Prelude> :l liftn.hs
[1 of 1] Compiling Main             ( liftn.hs, interpreted )

liftn.hs:22:28: error:
    * Couldn't match expected type `LiftN f x'
                  with actual type `(a0 -> b0) -> (a0 -> a0) -> a0 -> b0'
      The type variables `a0', `b0' are ambiguous
    * In the expression: go (natVal (Proxy :: Proxy (Length x)))
      In an equation for `liftN':
          liftN (Proxy :: Proxy x)
            = go (natVal (Proxy :: Proxy (Length x)))
            where
                go 1 = pure
                go 2 = fmap
                go n = undefined
    * Relevant bindings include
        liftN :: Proxy x -> LiftN f x (bound at liftn.hs:22:1)
   |
22 | liftN (Proxy :: Proxy x) = go (natVal (Proxy :: Proxy (Length x))) where
   |                            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Failed, no modules loaded.

At this point it isn't clear to me what exactly is ambiguous or how to disambiguate it.

Is there a way to elegantly (or if not-so-elegantly, in a way that the inelegance is constrained to the function implementation) implement the body of liftN here?

Answer 1

There are two issues here:

• You need more than just the natVal of a type-level number to ensure the whole function type checks: you also need a proof that the structure you're recursing on corresponds to the type-level number you're referring to. Integer on its own loses all of the type-level information.
• Conversely, you need more runtime information than just the type: in Haskell, types have no runtime representation, so passing in a Proxy a is the same as passing in (). You need to get in runtime info somewhere.

Both of these problems can be addressed using singletons, or with classes:

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE FlexibleContexts      #-}

data Nat = Z | S Nat

type family AppFunc f (n :: Nat) arrows where
  AppFunc f Z a = f a
  AppFunc f (S n) (a -> b) = f a -> AppFunc f n b

type family CountArgs f where
  CountArgs (a -> b) = S (CountArgs b)
  CountArgs result = Z

class (CountArgs a ~ n) => Applyable a n where
  apply :: Applicative f => f a -> AppFunc f (CountArgs a) a

instance (CountArgs a ~ Z) => Applyable a Z where
  apply = id
  {-# INLINE apply #-}

instance Applyable b n => Applyable (a -> b) (S n) where
  apply f x = apply (f <*> x)
  {-# INLINE apply #-}

-- | >>> lift (\x y z -> x ++ y ++ z) (Just "a") (Just "b") (Just "c")
-- Just "abc"
lift :: (Applyable a n, Applicative f) => (b -> a) -> (f b -> AppFunc f n a)
lift f x = apply (fmap f x)
{-# INLINE lift #-}

This example is adapted from Richard Eisenberg's thesis.