Function composition where 2nd function is variadic

wrap.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

import Data.Proxy (Proxy(..))

-- | Typeclass to compose a function (f :: a -> b) with the result
-- of a function (g) which has any number of arguments, resulting in a
-- function with type (h).
class MapResult (gHasArg :: Bool) f g h where
  mapResultImpl :: Proxy gHasArg -> f -> g -> h

-- | Handle base case where (g) is the result value to map.
instance MapResult 'False (a -> r) a r where
  mapResultImpl _ f x = f x

-- | Handle recursive case.
instance
  MapResult (HasArg g) f g h
  => MapResult 'True f (x -> g) (x -> h) where
  mapResultImpl _ f g =
    \x -> mapResultImpl (Proxy @ (HasArg g)) f (g x)

-- | Composes a function (a -> b) with a variadic function (g) which
-- has a final result type of (a).
--
-- This is a wrapper around mapResultImpl which provides a Proxy of an
-- appropriate type. It also uses some type families for getting the
-- ResultType of (g) and substituting the result type. The usage of
-- these type families could be omitted, but this would result in poor
-- type inference (more explicit types needed) and poor type errors.
mapResult
  :: forall a b g h.
     ( a ~ ResultType g
     , h ~ WithResultType b g
     , MapResult (HasArg g) (a -> b) g h
     )
  => (a -> b) -> g -> h
mapResult = mapResultImpl (Proxy @ (HasArg g))

--------------------------------------------------------------------------------
-- Usage example
--------------------------------------------------------------------------------

showAddNumbers :: Int -> Int -> String
showAddNumbers = mapResult show (+)

showAdd3Numbers :: Int -> Int -> Int -> String
showAdd3Numbers = mapResult show (\x y z -> x + y + z)

main :: IO ()
main = do
  putStrLn (showAddNumbers 24 13)
  putStrLn (showAdd3Numbers 24 13 36)

--------------------------------------------------------------------------------
-- Type families to operate on functions
--------------------------------------------------------------------------------

-- | Gets result type of a function.
type family ResultType f where
  ResultType (_ -> f) = ResultType f
  ResultType r = r

-- | Substitutes result type of a function with another type.
type family WithResultType a f where
  WithResultType a (b -> f) = b -> WithResultType a f
  WithResultType a _ = a

-- | Checks whether the specified type is a function type.
type family HasArg f where
  HasArg (_ -> _) = 'True
  HasArg _ = 'False