Multiple MonadReader constraints on a single method

Question

It doesn't look like anything stops you from defining a function like this:

tmp :: (MonadReader Int m, MonadReader Bool m) => m Int
tmp = ifM ask ((+1) <$> ask) ((+2) <$> ask)

So would be something like a typeable context, where as long as you give it a type, ask will give you the part of the environment with that type, which I think is a reasonable alternative to name shadowing.

However, with the default instances of MonadReader defined by Control.Monad.Reader, it doesn't look like there's a way to actually invoke this method. So I defined a new module that attempts to do this:

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses,
  UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Control.Monad.Reader.Extra
  ( MonadReader(ask)
  ) where

import Control.Monad.Reader (MonadReader(ask, local, reader))
import Control.Monad.Trans.Class (MonadTrans(lift))

instance {-# OVERLAPPABLE #-} ( Monad m
                              , MonadTrans t
                              , Monad (t m)
                              , MonadReader r m
                              ) =>
                              MonadReader r (t m) where
  ask = lift ask
  local _ _ = undefined
  reader f = lift (reader f)

As long as this second instance is in scope, you'll be able to run tmp, like runReaderT (runReaderT tmp 1) True.

Unfortunately, I can't figure out a decent implementation for local, since it needs to have the type local :: (r -> r) -> (t m a) -> (t m a), but it doesn't seem like there's a way to lift a local :: (r -> r) -> m a -> m a to this.

What would be a reasonable implementation for local for this instance?

Minimal Complete example:

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, LambdaCase, FlexibleContexts #-}
module Tmpfundep where

import Control.Monad.Reader
  ( MonadReader(ask, local, reader)
  , ReaderT(ReaderT)
  , runReaderT
  )

instance {-# INCOHERENT #-} (Monad m, MonadReader r m) =>
                            MonadReader r (ReaderT r' m) where
  ask = ReaderT (const ask)
  local f (ReaderT m) = ReaderT (local f . m)
  reader f = ReaderT (const (reader f))

withEnv :: r -> ReaderT r m a -> m a
withEnv r m = runReaderT m r

tmp :: (MonadReader Int m, MonadReader Bool m) => m Int
tmp = ask >>= \case
  True -> (+1) <$> ask
  False -> (+2) <$> ask

main :: IO ()
main = withEnv True (withEnv (1 :: Int) tmp) >>= print

Was able to run this with echo main | stack exec -- runghc Tmpfundep.hs

Multiple MonadReader constraints on a single method

0 Answers