Curry-tf.hs

{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}

module CurryTf where

-- uncurry :: (a -> b -> c) -> (a, b) -> c
-- uncurry2 :: (a -> b -> c -> d) -> (a, b, c) -> d
-- uncurry3 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
-- ...
-- This is tedious! Also, we need to know in advance the arity of the
-- function we want to uncurry, so that we can pick the right one.
--
-- What if we had one uncurry to rule them all?

-- The first problem is that tuples are a little awkward to work with:
-- other than syntactic resemblance, there isn't much in common
-- between a 2-tuple and a 3-tuple. Crucially, there is no way to
-- extend an n-tuple to an n+1-tuple.

-- Thus, our vehicle for carrying our arguments will be an old
-- heterogeneous list.
data HList :: [*] -> * where
  HNil :: HList '[]
  (:>) :: a -> HList as -> HList (a ': as)

infixr 5 :>

-- In order to have a general way of uncurrying a function, we need
-- to somehow inspect the function's type, and figure out what the
-- arguments to the function are.
--
-- For example, a function with type `(a -> b -> c -> d -> e)`
-- should be uncurried into a funciton that takes an `HList '[a, b, c, d]`
-- and returns an `e`:
--
-- uncurry3' :: (a -> b -> c -> d -> e) -> HList '[a, b, c, d] -> e

-- The cleanest way of computing this type from a function's type is
-- to use a type family.
-- Args takes as argument a function, and returns a (type-level) list
-- of its arguments, by recursively taking apart the `->`s it can find
-- in the input type.

type family Args (x :: *) :: [*] where
  Args (a -> r) = a ': Args r
  Args _ = '[]

-- And now we can inspect the argument types of any function type:
--
-- *CurryTf> :kind! Args (Int -> Int)
-- '[Int]
--
-- *CurryTf> :kind! Args (Int -> String -> Char -> Bool)
-- '[Int, [Char], Char]

-- We define another type family for getting the result of a function type:
type family Result (x :: *) :: * where
  Result (_ -> r) = Result r
  Result r = r

-- *CurryTf> :kind! Result (Int -> String -> Char -> Bool)
-- Bool

-- The type of our uncurry function is thus
-- uncurryN :: function -> HList (Args function) -> Result function

-- To actually define `uncurryN`, we will need to do case analysis
-- on the `function`'s type to see how many argument it has left.
class Uncurry fun where
  uncurryN :: fun -> HList (Args fun) -> Result fun

-- We have two cases:

-- - 1: `fun` is a function from some `y` to `v`.
--      This amounts to chopping off the first argument, and then finding
--      the suitable 'y' value in the HList to feed it to our function.
instance Uncurry v => Uncurry (y -> v) where
  -- By substituting our (y -> v) into `fun`, we get the following
  -- type signature from the class definition:
  -- uncurryN :: (y -> v) -> HList (Args (y -> v)) -> Result (y -> v)
  --
  -- GHC will try to expand the type families as far as it can, which
  -- means it will lift out one layer from both
  -- `Args (y -> v)` and `Result (y -> v)`.
  --
  -- uncurryN :: (y -> v) -> HList (y ': Args v) -> Result v
  uncurryN p (x :> xs) = uncurryN (p x) xs
  --                      ^
  --                      +-- uncurryN :: v -> Args v -> Result v
  --                          ---------
  --                          this is exactly what we have from the
  --                          `Uncurry v` constraint at the top of the
  --                          instance

-- - 2: The base case, when `fun` is not a function type.
--      This instance head, `Uncurry a` would match any type, functions
--      included, so we say that it's OVERLAPPABLE.
--      This will result in the other instance being preferred, as it is
--      strictly more specific. This is the fallback instance, when
--      we really don't have a function at hand.
instance {-# OVERLAPPABLE #-} Result a ~ a => Uncurry a where
  -- uncurryN :: a -> HList (Args a) -> Result a
  -- since we required that `Result a ~ a`, we get
  -- uncurryN :: a -> HList (Args a) -> a
  uncurryN p _ = p

--------------------------------------------------------------------------------
-- * And that's it! Let's see a few examples:

data Product = Product
  { foo :: Int
  , bar :: String
  , baz :: String
  } deriving Show

prod = uncurryN Product (10 :> "hello" :> "world" :> HNil)

-- >>> prod
-- Product {foo = 10, bar = "hello", baz = "world"}

tuple = uncurryN (,,) (10 :> "hello" :> "world" :> HNil)

-- >>> tuple
-- (10,"hello","world")

----------------------------------------------------------------------------------
-- * We even have very good type inference, thanks to the type families:

-- >>> :t uncurryN (,,)
-- uncurryN (,,) :: HList '[a, b, c] -> (a, b, c)

-- >>> :t uncurryN Product
-- uncurryN Product :: HList '[Int, [Char], [Char]] -> Product