Created
February 14, 2019 06:47
-
-
Save sevanspowell/b6386cefa49c0d38e919b5e9bf7be583 to your computer and use it in GitHub Desktop.
Abstracting source of function parameters using MonadReader
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE FlexibleContexts #-} | |
{-# LANGUAGE InstanceSigs #-} | |
{-# LANGUAGE FlexibleInstances #-} | |
{-# LANGUAGE MultiParamTypeClasses #-} | |
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
{-# LANGUAGE DeriveFunctor #-} | |
module DynamicReader where | |
import Control.Monad.Reader (MonadReader(ask, local), ask, ReaderT(ReaderT), runReaderT) | |
import Data.Time.Clock (UTCTime, getCurrentTime) | |
data Env = Env String | |
data Result = ResultGood | ResultBad | |
deriving Show | |
-- We have two different ways of getting the environment, | |
-- statically: | |
-- usesEnv :: Env -> Result | |
-- and dynamically: | |
-- usesEnv :: m Env -> m Result | |
-- I wanted to have a function that abstracted away the idea that | |
-- the Env was fetched dynamically or statically, i.e. the implementation | |
-- didn't care how it was fetched. | |
-- The following function can capture both of these functions: | |
usesEnv :: MonadReader Env m => m Result | |
usesEnv = do | |
env <- ask | |
case env of | |
(Env "good") -> pure $ ResultGood | |
_ -> pure $ ResultBad | |
-- To recover the static behaviour, we call the function like so: | |
mainStatic :: IO () | |
mainStatic = do | |
let env = Env "good" | |
-- usesEnv specialises to `usesEnv :: Env -> Result` in this case, no | |
-- side-effects. | |
let result = usesEnv env | |
print result | |
-- To recover the dynamic behaviour, we have to create a MonadReader instance | |
-- for a type that dynamically retrieves the Env. | |
-- Let's call this type `DynamicReaderT`, modelled off `ReaderT`: | |
newtype DynamicReaderT r m a = DynamicReaderT { runDynamicReaderT :: m r -> m a } | |
-- ReaderT has the signature `r -> m a`. | |
-- DynamicReaderT is very similar, but has the signature `m r -> m a` to reflect | |
-- the fact that the `r` is retrieved as a monadic action. | |
-- We can make a MonadReader instance for DynamicReaderT: | |
instance Monad m => MonadReader r (DynamicReaderT r m) where | |
ask :: DynamicReaderT r m r | |
ask = DynamicReaderT $ id | |
local :: (r -> r) -> DynamicReaderT r m a -> DynamicReaderT r m a | |
local modify dyn = DynamicReaderT $ \mr -> | |
let | |
mr' = modify <$> mr | |
in | |
runDynamicReaderT dyn $ mr' | |
-- Which lets us recover our dynamic behaviour: | |
mainDynamic :: IO () | |
mainDynamic = do | |
envAction <- cachedEnv | |
-- usesEnv specialises to `usesEnv :: DynamicReaderT Env IO Result` | |
result <- (flip runDynamicReaderT) envAction $ usesEnv | |
print result | |
-- Dummy "dynamic" action | |
cachedEnv :: IO (IO Env) | |
cachedEnv = pure . pure $ Env "good" | |
-- Let's verify it's correctness: | |
getTime :: IO (IO UTCTime) | |
getTime = pure $ getCurrentTime | |
usesTime :: MonadReader UTCTime m => m (UTCTime, UTCTime) | |
usesTime = do | |
time1 <- ask | |
time2 <- ask | |
pure (time1, time2) | |
mainTimeDynamic :: IO () | |
mainTimeDynamic = do | |
timeAction <- getTime | |
(t1, t2) <- (flip runDynamicReaderT) timeAction $ usesTime | |
putStrLn $ show t1 | |
putStrLn $ show t2 | |
-- λ> mainTimeDynamic | |
-- 2019-02-14 05:21:32.90285643 UTC | |
-- 2019-02-14 05:21:32.90298538 UTC | |
-- Notice changing time. | |
mainTimeStatic :: IO () | |
mainTimeStatic = do | |
time <- getCurrentTime | |
let (t1, t2) = usesTime time | |
putStrLn $ show t1 | |
putStrLn $ show t2 | |
-- λ> mainTimeStatic | |
-- 2019-02-14 06:14:23.715250967 UTC | |
-- 2019-02-14 06:14:23.715250967 UTC | |
-- Notice same time. | |
-- Thanks to #qfpl, it turns out that DynamicReaderT can be more easily expressed as: | |
newtype DReaderT r m a = DReaderT (ReaderT (m r) m a) | |
deriving (Functor, Applicative, Monad) | |
runDReaderT :: DReaderT r m a -> m r -> m a | |
runDReaderT (DReaderT reader) = runReaderT reader | |
instance Monad m => MonadReader r (DReaderT r m) where | |
ask :: DReaderT r m r | |
ask = DReaderT . ReaderT $ id | |
local :: (r -> r) -> DReaderT r m a -> DReaderT r m a | |
local modify reader = DReaderT . ReaderT $ \mr -> | |
let | |
mr' = modify <$> mr | |
in | |
runDReaderT reader mr' | |
mainTimeDynamic' :: IO () | |
mainTimeDynamic' = do | |
timeAction <- getTime | |
(t1, t2) <- flip runDReaderT timeAction $ usesTime | |
putStrLn $ show t1 | |
putStrLn $ show t2 | |
-- λ> mainTimeDynamic' | |
-- 2019-02-14 06:22:12.911106505 UTC | |
-- 2019-02-14 06:22:12.911107567 UTC | |
-- Notice changing time. | |
-- Something to watch out for: | |
-- The signature of `ask` is `ask :: m r`. Nothing about this signature suggests | |
-- that `r` doesn't change between calls. Quite the opposite, the `m` signals that | |
-- the `r` might change between calls, we're operating in a monadic context after all. | |
-- We're taking advantage of exactly this in `usesTime` to have the time change between | |
-- calls to `ask` in the dynamic implementation, and not change in the static implementation. | |
-- However, most people don't think about this when using ask and will probably assume that | |
-- using `ask` twice in the body of a function returns the same result. This is true in our | |
-- static case, but definitely not true in our dynamic case. | |
-- DynamicReaderT Functor, Applicative, and Monad instances. | |
instance (Functor m) => Functor (DynamicReaderT r m) where | |
fmap :: (a -> b) -> DynamicReaderT r m a -> DynamicReaderT r m b | |
fmap f dyn = DynamicReaderT $ fmap f . (runDynamicReaderT dyn) | |
instance (Applicative m) => Applicative (DynamicReaderT r m) where | |
pure :: a -> DynamicReaderT r m a | |
pure = DynamicReaderT . const . pure | |
(<*>) :: DynamicReaderT r m (a -> b) -> DynamicReaderT r m a -> DynamicReaderT r m b | |
dynFn <*> dynA = DynamicReaderT $ \mr -> | |
let | |
mfn = (runDynamicReaderT dynFn) mr | |
ma = (runDynamicReaderT dynA) mr | |
in | |
mfn <*> ma | |
instance (Monad m) => Monad (DynamicReaderT r m) where | |
(>>=) :: DynamicReaderT r m a -> (a -> DynamicReaderT r m b) -> DynamicReaderT r m b | |
dynA >>= fn = DynamicReaderT $ \mr -> | |
let | |
ma = (runDynamicReaderT dynA) mr | |
fn' = flip runDynamicReaderT mr . fn | |
in | |
ma >>= fn' | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment