Next Level MTL

Classy.hs

-- TH expansions of `makeClassy` and `makeClassyPrisms`

data DbConfig = DbConfig
  { _dbConn :: DbConnection
  , _dbSchema :: Schema
  }

makeClassy ''DbConfig
{-
class HasDbConfig t where
  dbConfig :: Lens' t DbConfig
  dbConn :: Lens' t DbConnection
  dbSchema :: Lens' t Schema

  dbConn = dbConfig . dbConn
  dbSchema = dbConfig . dbSchema

instance HasDbConfig DbConfig where
  dbConfig = id
  dbConn = lens _dbConn (\d c -> d { _dbConn = c })
  dbSchema = lens _dbSchema (\d s -> d { _dbSchema = s })
-}



data DbError = QueryError Text | InvalidConnection

makeClassyPrisms ''DbError
{-
class AsDbError t where
  _DbError :: Prism' t DbError
  _QueryError :: Prism' t Text
  _InvalidConn :: Prism' t ()

  _QueryError = _DbError . _QueryError
  _InvalidConn = _DbError . _InvalidConn

instance AsDbError DbError where
  _DbError = id
  _QueryError =
    prism' QueryError $ \e -> case e of
                                QueryError t -> Just t
                                _            -> Nothing
  _InvalidConn =
    prism' (const InvalidConnection) $ \e -> case e of
                                               InvalidConnection -> Just ()
                                               _                 -> Nothing
-}

Minimal.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

{-
  Demonstration of how to use MTL and Lenses to make type-safe monadic
  composition simple. Based on code from George Wilson's Next Level
  MTL talk (https://youtu.be/GZPup5Iuaqw), and tested with the
  following dependencies:

    - lens >= 4.15.4 && < 4.16
    - mtl >= 2.2.1 && < 2.3
    - text >= 1.2.2.2 && < 1.3
-}

module Minimal
    ( main
    ) where

import Control.Lens
import Control.Lens.Prism
import Control.Lens.TH
import Control.Monad.Except
import Control.Monad.Reader
import Data.Text

data DbConnection
data Schema
data Port
data Ssl

data DbConfig = DbConfig
  { _dbConn :: DbConnection
  , _dbSchema :: Schema
  }
makeClassy ''DbConfig

data NetworkConfig = NetConfig
  { _port :: Port
  , _ssl :: Ssl
  }
makeClassy ''NetworkConfig

data AppConfig = AppConfig
  { appDbConfig :: DbConfig
  , appNetConfig :: NetworkConfig
  }
makeClassy ''AppConfig

instance HasDbConfig AppConfig where
  dbConfig = appConfig . dbConfig

instance HasNetworkConfig AppConfig where
  networkConfig = appConfig . networkConfig

--------------------------------------------------------------------------------

data DbError = QueryError Text | InvalidConnection
  deriving Show
makeClassyPrisms ''DbError

data NetworkError = Timeout Int | ServerOnFire
  deriving Show
makeClassyPrisms ''NetworkError

data AppError = AppDbError DbError | AppNetworkError NetworkError
  deriving Show
makeClassyPrisms ''AppError

instance AsDbError AppError where
  _DbError = _AppError . _DbError

instance AsNetworkError AppError where
  _NetworkError = _AppError . _NetworkError

--------------------------------------------------------------------------------

newtype App a = App { unApp :: ReaderT AppConfig (ExceptT AppError IO) a }
  deriving
    ( Functor
    , Applicative
    , Monad
    , MonadReader AppConfig
    , MonadError AppError
    , MonadIO
    )

data MyData

loadFromDb :: ( MonadError e m, MonadReader r m
              , AsDbError e, HasDbConfig r
              , MonadIO m )
              => m MyData
loadFromDb = undefined

sendOverNet :: ( MonadError e m, MonadReader r m
               , AsNetworkError e, HasNetworkConfig r
               , MonadIO m )
               => MyData -> m ()
sendOverNet = undefined

loadAndSend :: ( MonadError e m, MonadReader r m
               , AsNetworkError e, HasNetworkConfig r
               , AsDbError e, HasDbConfig r
               , MonadIO m )
               => m ()
loadAndSend = loadFromDb >>= sendOverNet

mainApp :: App ()
mainApp = loadAndSend

runApp :: App a -> AppConfig -> IO (Either AppError a)
runApp app cfg = runExceptT $ runReaderT (unApp app) cfg

main :: IO ()
main = runApp mainApp config >>= either print return
  where
    config :: AppConfig
    config = undefined