Haskell free monad example

FreeMonadPayment.hs

module FreeMonadPayment where

import Control.Monad.Free
import Control.Monad.Except
import Data.Text hiding (unpack)
import Control.Error
import Data.Function
import Data.Bifunctor
import Control.Newtype (unpack, Newtype)

newtype EmailAddress = EmailAddress Text

data Email = Email { to :: EmailAddress, body :: Text }

data CreditCard = CreditCard {
  number :: Text,
  expiry :: Text,
  cvv :: Text
}

data PaymentError =
    InsufficientFunds
  | CardExpired

newtype TransactionId = TransactionId Text

instance Newtype TransactionId Text

newtype UserId = UserId Text

data User = User {
  userId :: UserId,
  creditCard :: CreditCard,
  emailAddress :: Maybe EmailAddress
}

data Operation next =
    LookupUser UserId (Maybe User -> next)
  | ChargeCreditCard (Float, CreditCard) (Either PaymentError TransactionId -> next)
  | EmailReceipt Email next

deriving instance Functor Operation

data Error =
    PaymentError PaymentError
  | UserNotFound

type Program = Free Operation

lookupUser :: UserId -> ExceptT Error Program User
lookupUser userId = LookupUser userId id & fmap (note UserNotFound) & liftF & ExceptT

chargeCreditCard :: Float -> CreditCard -> ExceptT Error Program TransactionId
chargeCreditCard amount card = ChargeCreditCard (amount, card) id & fmap (first PaymentError) & liftF & ExceptT

emailReceipt :: Email -> ExceptT Error Program ()
emailReceipt email = EmailReceipt email () & liftF & lift

chargeUser :: Float -> UserId -> Program (Either Error TransactionId)
chargeUser amount userId = runExceptT $ do
  user <- lookupUser userId
  transactionId <- chargeCreditCard amount (creditCard user)
  case emailAddress user of
    Just emailAddress -> do
      emailReceipt Email { to = emailAddress, body = "TransactionId " <> unpack transactionId }
      pure transactionId
    Nothing -> pure transactionId

TypeClassPayment.hs

module TypeClassPayment where

import Control.Monad.Except
import Data.Text hiding (unpack)
import Control.Error
import Data.Bifunctor
import Control.Newtype (unpack, Newtype)

newtype EmailAddress = EmailAddress Text

data Email = Email { to :: EmailAddress, body :: Text }

data CreditCard = CreditCard {
  number :: Text,
  expiry :: Text,
  cvv :: Text
}

data PaymentError =
    InsufficientFunds
  | CardExpired

newtype TransactionId = TransactionId Text

instance Newtype TransactionId Text

newtype UserId = UserId Text

data User = User {
  userId :: UserId,
  creditCard :: CreditCard,
  emailAddress :: Maybe EmailAddress
}

class Operations f where
  lookupUser :: UserId -> f (Maybe User)
  chargeCreditCard :: Float -> CreditCard -> f (Either PaymentError TransactionId)
  emailReceipt :: Email -> f ()

data Error =
    PaymentError PaymentError
  | UserNotFound

chargeUser :: (Operations f, Monad f) => Float -> UserId -> f (Either Error TransactionId)
chargeUser amount userId = runExceptT $ do
  user <- ExceptT $ note UserNotFound <$> lookupUser userId
  transactionId <- ExceptT $ first PaymentError <$> chargeCreditCard amount (creditCard user)
  case emailAddress user of
    Just emailAddress -> do
      lift $ emailReceipt Email { to = emailAddress, body = "TransactionId " <> unpack transactionId }
      pure transactionId
    Nothing -> pure transactionId