Извлечение единицы из гетерогенной коллекции

Question

Недавно я работал над проектом, который использует несколько различных монадных трансформаторов. Я устал писать функции для запуска различных стеков монады, поэтому решил написать общую функцию для их выполнения. Это звучит примерно так:

class MonadRun outer args inner | outer -> args, args outer -> inner where 
    monadRun :: outer -> args -> inner 

-- Base instances: The Identity monad can be removed, while other monads, in general, cannot 
instance MonadRun (Identity a)() a where 
    monadRun a _ = runIdentity a 

instance (Monad m, ma ~ (m a), ma' ~ (m a), u ~()) => MonadRun ma u ma' where 
    monadRun a _ = a 

Тогда у меня есть примеры для каждой из монад трансформаторов:

instance (MonadRun (m a) r' m') => MonadRun (ReaderT r m a) (r, r') m' where 
    monadRun outer (r, r') = monadRun (runReaderT outer r) r' 

Остальные экземпляры просто шаблонный, так же, как, например ReaderT. Если у меня есть монада, такие как

> type Test = StateT Int (ReaderT Bool IO) 
>:t monadRun (undefined :: Test()) 
monadRun (undefined :: Test()) :: (Int, (Bool,())) -> IO ((), Int) 

тип полученной функции имеет избыточную (); она должна быть уменьшена до (Int, Bool) -> IO ((), Int) (в () в возвращаемый тип должны быть удалены, а также, если это возможно, но это не так важно для меня.) Я могу переопределить экземпляр следующим образом:

instance (MonadRun (m a) r' m', r'' ~ (r, r')) => MonadRun (ReaderT r m a) r'' m' where 
    monadRun outer (r, r') = monadRun (runReaderT outer r) r' 

instance (MonadRun (m a)() m') => MonadRun (ReaderT r m a) r m' where 
    monadRun outer r = monadRun (runReaderT outer r)() 

и я буду получить правильный тип. Теперь вопросы:

1. Кто-то написал что-то подобное уже (запускает произвольные стеки монады)? Если это так, я могу отказаться от своих усилий.

2. Может ли это быть написано так, чтобы единицы были «автоматически» удалены из результирующего типа? В данном примере в конце происходит (). Но это не всегда так, () может происходить в любом месте стека. Я пытался сделать что-то подобное, но не смог заставить его работать.

class Tuple a b c | a b -> c where fst' :: c -> a; snd' :: c -> b; 
instance Tuple a() a .... 
instance Tuple() a a .... 
instance Tuple a b (a,b) .... 

3. Вместо какого-либо сложного вложенного кортежа, существует ли другая (лучшая) гетерогенная коллекция, которую я могу использовать?

For those interested, here is the complete code.

Answer 1

Так что я, наконец, получил это 'работает'. Прежде всего я создал гетерогенную коллекцию, используя DataKinds:

infixr 7 :> 
data Args (xs :: [*]) where 
    None :: Args '[] 
    (:>) :: x -> Args xs -> Args (x ': xs) 

type family Concat (a :: [*]) (b :: [*]) :: [*] 
type instance Concat '[] ys = ys 
type instance Concat (x ': xs) ys = x ': (Concat xs ys) 

concatArgs :: Args xs -> Args ys -> Args (Concat xs ys) 
concatArgs None x = x 
concatArgs (x :> xs) ys = x :> concatArgs xs ys 

Тогда класс для выполнения одного уровня монады:

class Rule tyCons m input fr res | tyCons -> m input fr res where 
    rule :: tyCons m fr -> Args input -> m (Args res) 

instance Monad m => Rule (ReaderT r) m '[r] a '[a] where 
    rule m (r :> None) = liftM (:> None) $ runReaderT m r 
    rule _ _ = undefined 

instance Monad m => Rule (WS.WriterT w) m '[] a '[a, w] where 
    rule m _ = liftM (\(x,y) -> x:>y:>None) $ WS.runWriterT m 

Тогда один для правил секвенирования:

class RunRules input args output | input -> args, args input -> output where 
    runRules :: input -> Args args -> output 

-- base case 
instance (Monad m, ma ~ (m a), u ~ '[], mar ~ (m (Args ar)), 
      RemU a ar -- if a ==() then '[] else '[a] 
     ) => RunRules ma u mar where 
    runRules a _ = liftM remU a 

-- recursive case 
instance 
    (Rule tyCon0 m0 arg0 fr0 out0, RunRules (m0 (Args out0)) arg1 (m1 f), UnpackArgs f f' 
    , args ~ Concat arg0 arg1, From arg0 args arg0 arg1 
    , Monad m1 
    ) => RunRules (tyCon0 m0 fr0) args (m1 f') where 
     runRules input args = liftM unpackArgs $ runRules (rule input arg0) arg1 
      where (arg0, arg1) = from (Proxy :: Proxy arg0) args