T.hs

{-# LANGUAGE TemplateHaskell, DataKinds, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, FlexibleInstances, FlexibleContexts #-}

module T where

import Control.Monad.Trans.Class
import Data.Traversable
import Language.Haskell.TH

autoLift :: Name -> Q Type -> Q [Dec]
autoLift className transTypeQ = do
  info <- reify className
  case info of
    ClassI classDec _ -> autoLift' classDec transTypeQ
    _ -> fail "Not a class"

autoLift' :: Dec -> Q Type -> Q [Dec]
autoLift' (ClassD _ name _vars _ fs) transTypeQ = do
  m <- newName "m"
  -- instance                  (MonadThing m) =>                    MonadThing (MyTrans m) where
  sequence
    [ instanceD (cxt [conT name `appT` varT m]) (conT name `appT` (transTypeQ `appT` varT m)) $
        -- someFun = lifts someFun
        flip fmap fs $ \fDec ->
          case fDec of
            SigD fName _ -> valD (varP fName) (normalB [|lifts $(varE fName)|]) []
            _ -> error $ "Unsupported class component: " ++ show fDec
    ]

type family IsArrow a :: Bool where
  IsArrow (a -> b) = 'True
  IsArrow a = 'False

type family Pre isArrow a where
  Pre 'True (a -> b) = a -> Pre (IsArrow b) b
  Pre 'False (t m a) = m a

-- Automatic lift of monad actions with n parameters.
class (isArrow ~ IsArrow t) => Lifts isArrow t where
  lifts :: Pre isArrow t -> t

instance Lifts (IsArrow b) b => Lifts 'True (a -> b) where
  lifts = fmap lifts

instance (MonadTrans t, Monad m, IsArrow (t m a) ~ 'False) => Lifts 'False (t m a) where
  lifts = lift

U.hs

{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, TemplateHaskell #-}

module U where

import T
import Control.Monad.Trans

-- A type with Monad and MonadTrans instances.

newtype I m a = I (m a)
  deriving (Functor, Applicative, Monad)

instance MonadTrans I where
  lift = I

-- A simple type class, where the type variable m occurs only to the right of a
-- series of arrows.

class Monad m => MonadInt m where
  monadInt0 :: m Int
  monadInt1 :: Int -> m Int
  monadInt2 :: Int -> Int -> m Int

-- Magic.

autoLift ''MonadInt [t|I|]