Deriving via -- no more transformers

Via.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Via where

import qualified Control.Lens          as Lens
import           Control.Monad.Reader
import           Data.Deriving.Via     
import qualified Data.Generics.Product as G.P
import           GHC.Generics

-- API

newtype Email          = Email String
newtype Password       = Password String
newtype HashedPassword = HashedPassword String

data Account        
  = Account 
      { _aEmail          :: Email 
      , _aHashedPassword :: HashedPassword
      }

class Monad m => MonadAccounts m where
  createAccount
    :: Email
    -> Password
    -> m Account

-- Impl

data AccountImplConfig
  = AccountImplConfig
      { _aicHashPassword :: Password -> HashedPassword
      }

newtype AccountT m a 
  = AccountT { runAccountT :: m a }
  deriving newtype (Applicative, Functor, Monad)

instance (MonadReader r m, G.P.HasType AccountImplConfig r)
      =>  MonadAccounts (AccountT m) where
  createAccount 
    = createAccountImpl
  {-# INLINE createAccount #-}

createAccountImpl
  :: (MonadReader r m,
      G.P.HasType AccountImplConfig r)
  => Email
  -> Password
  -> AccountT m Account
createAccountImpl email password = AccountT $ do
  hashPassword <- Lens.views (G.P.typed @AccountImplConfig) _aicHashPassword
  let hashedPassword = hashPassword password
  pure Account
    { _aEmail          = email
    , _aHashedPassword = hashedPassword
    }

bcrypt :: Password -> HashedPassword
bcrypt (Password password)
  = HashedPassword ("bcrypted:" ++ password)

-- Services that compose accounts

createJointApplicantAccounts
  :: MonadAccounts m
  => (Email, Password)
  -> (Email, Password)
  -> m (Account, Account)
createJointApplicantAccounts (email1, password1) (email2, password2)
  = (,) <$> createAccount email1 password1 <*> createAccount email2 password2

-- Main

newtype App a
  = App { _runApp :: ReaderT AppConfig IO a }
  deriving newtype (Applicative, Functor, Monad, MonadReader AppConfig)

runApp :: AppConfig -> App a -> IO a
runApp cfg (App m)
  = runReaderT m cfg

data AppConfig
  = AppConfig
      { _acAccountImplConfig :: AccountImplConfig
      , _acSomeOtherStuff    :: String
      }

  deriving Generic

-- With TH for now, but this would become:
--
-- newtype App a
--   = ...
--   deriving newtype (Applicative, ...)
--   deriving MonadAccounts via AccountT App
--
-- (or similar)
deriveVia [t| MonadAccounts App `Via` AccountT App |]

main :: IO ()
main = do
  let bcryptAccountConfig 
        = AccountImplConfig 
            { _aicHashPassword = bcrypt
            }
      appConfig
        = AppConfig
            { _acAccountImplConfig = bcryptAccountConfig
            , _acSomeOtherStuff    = "Some other stuff"
            }
  (_a1, _a2) <- runApp appConfig $ 
    createJointApplicantAccounts
      (Email "first@example.come", Password "hunter2")
      (Email "second@example.com", Password "god")
  pure ()