MTL.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}

module Mtl where

import Control.Monad.IO.Class
import Control.Monad.Except
import Control.Monad.Reader

data SomeEnv =
  SomeEnv
   { envA :: Int
   , envB :: String
   } deriving Show

checkIfIntIs8 :: MonadError String m => Int -> m String
checkIfIntIs8 8 = return     "This int is valid"
checkIfIntIs8 _ = throwError "This int is not 8"

checkIfStringIsValid :: MonadError String m => String -> m String
checkIfStringIsValid "valid" = return     "This string is valid"
checkIfStringIsValid _       = throwError "This string is NOT valid"

functionB
  :: ( MonadIO m
     , MonadReader SomeEnv m
     , MonadError String m
     )
  => Int -> m (String, String)
functionB i = do
  SomeEnv {envB} <- ask
  validInt       <- checkIfIntIs8 i
  validString    <- checkIfStringIsValid envB
  return (validInt, validString)

functionA
  :: ( MonadIO m
     , MonadReader SomeEnv m
     , MonadError String m
     )
  => m (String,String)
functionA = do
    SomeEnv {envA, envB} <- ask
    res <- functionB envA
    return res
  `catchError` \err -> do
    liftIO $ putStrLn err
    throwError "error"

main :: IO ()
main = do
  let env = SomeEnv 2 "test"
  res <- runExceptT $ runReaderT functionA env
  case res of
    Left  err -> error err
    Right res -> print res