Using a runtime value to choose a monad transformer stack

ConfigurableMonadStack.hs

-- in response to https://twitter.com/1akrmn/status/1263124698449272832
-- 
-- We have a polymorphic action which can be instantiated to multiple
-- transformer stacks, and the goal is to use a runtime value to
-- determine which monad transformer stack to use.
{-# LANGUAGE AllowAmbiguousTypes, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, QuantifiedConstraints, RankNTypes, StandaloneDeriving, TypeApplications, UndecidableInstances #-}
{-# OPTIONS -Wno-orphans #-}
module Main where
import Test.DocTest

import Prelude hiding (log)

import Control.Monad.IO.Class
import Control.Monad.Writer hiding (Product)
import Data.Functor.Product

-- $setup
-- >>> :set -XFlexibleContexts


-- First, let's define the problem. We have a typeclass for a monad
-- transformer...

class MonadLog m where
  log :: String -> m ()


-- Which can be either be instantiated with ConsoleLogT... 

newtype ConsoleLogT m a = ConsoleLogT { runConsoleLogT :: m a }
  deriving (Functor, Applicative, Monad)

instance MonadIO m => MonadLog (ConsoleLogT m) where
  log s = ConsoleLogT $ liftIO $ putStrLn s

deriving instance MonadWriter w m => MonadWriter w (ConsoleLogT m)


-- Or with NoLogT...

newtype NoLogT m a = NoLogT { runNoLogT :: m a }
  deriving (Functor, Applicative, Monad)

instance Monad m => MonadLog (NoLogT m) where
  log _ = pure ()

deriving instance MonadWriter w m => MonadWriter w (NoLogT m)


-- |
-- We also have a polymorphic action which can either be instantiated
-- with ConsoleLogT or with NoLogT:
--
-- >>> execWriterT $ runConsoleLogT action
-- begin
-- end
-- "middle"
-- >>> execWriterT $ runNoLogT action
-- "middle"
action :: (MonadLog m, MonadWriter String m) => m ()
action = do
  log "begin"
  tell "middle"
  log "end"


-- |
-- But we would like to use some runtime configuration variable, a
-- Bool, to decide which monad transformer stack to use. The following
-- attempt seems promising:
--
-- >>> runAction True $ log "hello"
-- hello
-- >>> runAction False $ log "hello"
runAction :: Bool
          -> (forall m. MonadLog m => m a)
          -> IO a
runAction True  body = runConsoleLogT body
runAction False body = runNoLogT      body

-- |
-- But unfortunately, the type @forall m. MonadLog m => m a@ means
-- that 'body' must work for _any_ 'm' which has a 'MonadLog'
-- instance, including @NoLogT Identity@. This is unfortunate, because
-- our 'action' only works with monad stacks which contain a 'WriterT'
-- layer.
--
-- >>> runAction True action
-- ...
-- ... Could not deduce (MonadWriter String ...
-- ...


-- My solution is to use Data.Functor.Product to instantiate the
-- body's 'm' with two monad transformer stacks at the same time.
--
--   data Product m n a = Pair (m a) (n a)

-- I must first write some instances to show that
-- @Product (ConsoleLogT m) (NoLogT m)@ is an appropriate monad
-- transformer stack for 'action':

instance (MonadLog m, MonadLog n)
      => MonadLog (Product m n) where
  log s = Pair (log s) (log s)

instance (MonadWriter w m, MonadWriter w n)
      => MonadWriter w (Product m n) where
  tell w = Pair (tell w) (tell w)
  listen (Pair ma na) = Pair (listen ma) (listen na)
  pass (Pair ma na) = Pair (pass ma) (pass na)

-- |
-- And now I can easily write a function which instantiates 'action'
-- with those two monad transformer stacks, and uses a Bool to
-- determine which instantiation to keep:
--
-- >>> execWriterT $ runLogT True action
-- begin
-- end
-- "middle"
-- >>> execWriterT $ runLogT False action
-- "middle"
runLogT :: MonadIO m
        => Bool -> Product (ConsoleLogT m) (NoLogT m) a -> m a
runLogT True  (Pair body _) = runConsoleLogT body
runLogT False (Pair _ body) = runNoLogT body


main :: IO ()
main = do
  doctest ["src/Main.hs"]