Haskell MTL and classy lenses example (ReaderT, ExceptT)

Lib.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Lib where

import           Protolude
import           Control.Lens.TH (makeClassy, makeClassyPrisms)


----------------------------------------------------------------
data UserConfig = UserConfig { _ucName :: !Text
                             , _ucId :: !Int
                             } deriving (Show)

newtype Settings = Settings { _stRoot :: FilePath
                            } deriving (Show)

data SettingsError = SettingsPathError Text | SettingsLoadFailed Text deriving (Show)
data UserError = UserNotFound Text | UserNotActive Text deriving (Show)


makeClassy ''Settings
makeClassy ''UserConfig

makeClassyPrisms ''SettingsError
makeClassyPrisms ''UserError
----------------------------------------------------------------


  
----------------------------------------------------------------
-- App errors has all error types
----------------------------------------------------------------
data AppError = AppSettingsError SettingsError
              | AppUserError UserError
              deriving (Show)
makeClassyPrisms ''AppError
              

-- Prism to get user error from app error
instance AsUserError AppError where
  _UserError = _AppUserError . _UserError

instance AsSettingsError AppError where
  _SettingsError = _AppSettingsError . _SettingsError
----------------------------------------------------------------



  
----------------------------------------------------------------
-- App config
----------------------------------------------------------------
data AppConfig = AppConfig { _appSettings :: Settings
                           , _appUser :: UserConfig
                           }
               deriving (Show)
makeClassy ''AppConfig
              
instance HasSettings AppConfig where
  settings = appConfig . appSettings

instance HasUserConfig AppConfig where
  userConfig = appConfig . appUser
----------------------------------------------------------------

main.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | Example of MTL & classy lenses
module Run where

import           Protolude
import qualified Data.Char as Char
import qualified Data.Text as Txt
import           Control.Lens
import           Control.Monad.Except (throwError, runExceptT)
import           Control.Monad.Trans.Reader (ReaderT, runReaderT)

import           Lib

-----------------------------------------------------------------------------
run :: IO ()
run = do
  putText "-----1"
  demoSingleExplictErrorType1

  putText ""
  putText "-----2"
  demoApp2

  putText ""
  putText "-----3"
  demoApp3

  putText ""
  putText "-----4"
  demoApp4
-----------------------------------------------------------------------------


-----------------------------------------------------------------------------
-- Explicit error type
-----------------------------------------------------------------------------
demoSingleExplictErrorType1 :: IO ()
demoSingleExplictErrorType1 = do
  let user = UserConfig "" 1

  x <- runExceptT (runReaderT actOnUser1 user)
  case x of
    Left e -> print e
    Right r -> print r

  
  
actOnUser1 :: ( Monad m
              , HasUserConfig r
              , MonadError UserError m
              , MonadReader r m
              ) => m Text
actOnUser1 = do
  n <- ask

  if Txt.null $ n ^. ucName
  then throwError $ UserNotFound "Name is blank"
  else pass
  
  pure $ n ^. ucName
-----------------------------------------------------------------------------



-----------------------------------------------------------------------------
-- "Combined" error type using prisms
--   but the reader only has user config (HasUserConfig) but no HasSettings
-----------------------------------------------------------------------------
demoApp2 :: IO ()
demoApp2 = do
  let user = UserConfig "" 1

  x <- runExceptT (runReaderT actOnUser2 user)
  case x of
    Left (e::AppError) -> do
      print e
      print $ preview _UserError e
      print $ e ^? _UserError
    Right r -> print r
  
  

actOnUser2 :: ( Monad m
              , HasUserConfig r
              , AsSettingsError e
              , AsUserError e
              , MonadError e m
              , MonadReader r m
              ) => m Text
actOnUser2 = do
  n <- ask

  if Txt.null $ n ^. ucName
  then throwError $ _UserError # UserNotFound "Name blank"
  else throwError $ _SettingsError # SettingsLoadFailed "No settings in the reader :("
  
  pure $ n ^. ucName
-----------------------------------------------------------------------------



-----------------------------------------------------------------------------
-- "Combined" settings using app config
-----------------------------------------------------------------------------
demoApp3 :: IO ()
demoApp3 = do
  let user = UserConfig "" 1
  let settings' = Settings "~"
  let config = AppConfig settings' user

  x <- runExceptT (runReaderT actOnUser3 config)
  case x of
    Left (e::AppError) -> do
      pass
      print e
      print $ preview _UserError e
      print $ e ^? _UserError
    Right r -> print r
  
  

actOnUser3 :: ( Monad m
              , HasSettings r
              , HasUserConfig r
              , AsSettingsError e
              , AsUserError e
              , MonadError e m
              , MonadReader r m
              ) => m Text
actOnUser3 = do
  n <- ask

  if Txt.null $ n ^. ucName
  then throwError $ _UserError # UserNotFound "Name blank"
  else pass
  
  if null $ n ^. stRoot
  then throwError $ _SettingsError # SettingsLoadFailed "Invalid root path"
  else pass
  
  pure $ n ^. ucName
-----------------------------------------------------------------------------


-----------------------------------------------------------------------------
-- AppT version of demoApp3
-----------------------------------------------------------------------------
newtype AppT m a = AppT { unAppT :: ReaderT AppConfig (ExceptT AppError m) a 
                        } deriving ( Functor
                                   , Applicative
                                   , Monad
                                   , MonadReader AppConfig
                                   , MonadError AppError
                                   )

demoApp4 :: IO ()
demoApp4 = do
  let user = UserConfig "" 1
  let settings' = Settings "~"
  let config = AppConfig settings' user

  x <- runExceptT (runReaderT (unAppT actOnUser4) config)
  case x of
    Left (e::AppError) -> do
      print e
      print $ preview _UserError e
      print $ e ^? _UserError
    Right r -> print r

  
-- AppT lets us do anything AppT can do
--   calls child4 with explicit constraints
actOnUser4 :: (Monad m) => AppT m Text
actOnUser4 = do
  n <- ask

  if Txt.null $ n ^. ucName
  then throwError $ _UserError # UserNotFound "Name blank"
  else pass
  
  nameIsValid <- child4_nameIsValid
  if nameIsValid
  then throwError $ _UserError # UserNotFound "Name blank"
  else pass
  
  if null $ n ^. stRoot
  then throwError $ _SettingsError # SettingsLoadFailed "Invalid root path"
  else pass
  
  pure $ n ^. ucName


-- Can only get user config, no access to settings and ability to return error
child4_nameIsValid :: ( Monad m
                      , HasUserConfig r
                      , MonadReader r m
                      ) => m Bool
child4_nameIsValid = do
  n <- ask
  pure $ Txt.all Char.isLower $ n ^. ucName