ReaderT Pattern example

three-layer-haskell-cake.hs

{-
  This is a port of https://jordanmartinez.github.io/purescript-jordans-reference-site/content/21-Hello-World/05-Application-Structure/src/02-MTL/32-The-ReaderT-Capability-Design-Pattern.html

  There was no simple, working example of the ReaderT pattern in Haskell
-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import qualified Control.Monad.IO.Class as MonadIO
import qualified Control.Monad.Reader as Reader
import Prelude

-- Layer 4

newtype Name = Name String

getName :: Name -> String
getName (Name s) = s

-- Layer 3

-- Capability type classes:
class Monad m => LogToScreen m where
  putLog :: String -> m ()

class Monad m => GetUserName m where
  getUserName :: m Name

-- Business logic that uses these capabilities
-- which makes it easier to test
program ::
  LogToScreen m =>
  GetUserName m =>
  m ()
program = do
  putLog "What is your name?"
  name <- getUserName
  putLog $ "You name is " <> (getName name)

-- Layer 2 (Production)

-- Environment type
data Environment = Environment {someValue :: Int} -- mutable state, read-only values, etc. go in this record

-- newtyped ReaderT that implements the capabilities
newtype AppM a = AppM (Reader.ReaderT Environment IO a)
  deriving (Functor, Applicative, Monad, MonadIO.MonadIO, Reader.MonadReader Environment)

runApp :: AppM a -> Environment -> IO a
runApp (AppM fInReaderT) env = Reader.runReaderT fInReaderT env

-- Layer 1 (the implementations of each instance)
instance LogToScreen AppM where
  putLog = MonadIO.liftIO . putStrLn

instance GetUserName AppM where
  getUserName = MonadIO.liftIO $ do
    -- some IOful thing that produces a string
    Name <$> getLine

-- Layer 0 (production)
main :: IO ()
main = do
  let globalEnvironmentInfo = Environment 123
  runApp program globalEnvironmentInfo

-----------------------
-- Layer 2 (test)

-- newtyped ReaderT that implements the capabilities for testing
newtype TestM a = TestM (Reader.ReaderT Environment IO a)
  deriving (Functor, Applicative, Monad, MonadIO.MonadIO, Reader.MonadReader Environment)

runTest :: TestM a -> Environment -> IO a
runTest (TestM fInReaderT) env = Reader.runReaderT fInReaderT env

-- Layer 1 (test: implementations of instances)
instance LogToScreen TestM where
  putLog _ = pure () -- no need to implement this

instance GetUserName TestM where
  getUserName = pure (Name "John") -- general idea. Don't do this in real code.

-- Layer 0 (test)
mainTest :: IO ()
mainTest = do
  let globalEnvironmentInfo = Environment 123 -- mutable state, read-only values, etc.
  runTest program globalEnvironmentInfo

Very helpful, thanks for putting this up.