Example.hs

-- Domain/UserAccount.hs
module Domain.UserAccount where

data UserAccount = UserAccount 
  { accountId :: Int
  , username :: String
  , email :: String
  } deriving (Show)

data UserAccountEvent 
  = UserAccountCreated UserAccount 
  | UserAccountEmailUpdated UserAccount String
  deriving (Show)

-- Domain/UserAccountRepository.hs
module Domain.UserAccountRepository where

import Domain.UserAccount

class Monad m => UserAccountRepository m where
  saveUserAccount :: UserAccount -> m ()
  findUserAccountById :: Int -> m (Maybe UserAccount)

-- Application/UserAccountService.hs
module Application.UserAccountService where

import Control.Monad.Except
import Domain.UserAccount
import Domain.UserAccountRepository

createUserAccount :: (MonadError String m, UserAccountRepository m) => String -> String -> m UserAccountEvent
createUserAccount name email = do
  let account = UserAccount 0 name email  -- ID will be set by the repository
  saveUserAccount account
  return $ UserAccountCreated account

updateUserAccountEmail :: (MonadError String m, UserAccountRepository m) => Int -> String -> m UserAccountEvent
updateUserAccountEmail accountId newEmail = do
  maybeAccount <- findUserAccountById accountId
  case maybeAccount of
    Just account -> do
      let updatedAccount = account { email = newEmail }
      saveUserAccount updatedAccount
      return $ UserAccountEmailUpdated updatedAccount newEmail
    Nothing -> throwError "User account not found"

-- Infrastructure/InMemoryUserAccountRepository.hs
module Infrastructure.InMemoryUserAccountRepository where

import Control.Monad.State
import qualified Data.Map as Map
import Domain.UserAccount
import Domain.UserAccountRepository

newtype InMemoryUserAccountRepository a = InMemoryUserAccountRepository { runInMemory :: StateT (Map.Map Int UserAccount) IO a }
  deriving (Functor, Applicative, Monad, MonadState (Map.Map Int UserAccount), MonadIO)

instance UserAccountRepository InMemoryUserAccountRepository where
  saveUserAccount account = do
    accounts <- get
    let newId = if Map.null accounts then 1 else maximum (Map.keys accounts) + 1
        newAccount = account { accountId = newId }
    put $ Map.insert newId newAccount accounts

  findUserAccountById accountId = do
    accounts <- get
    return $ Map.lookup accountId accounts

-- Main.hs
module Main where

import Control.Monad.Except
import Control.Monad.State
import qualified Data.Map as Map
import Domain.UserAccount
import Application.UserAccountService
import Infrastructure.InMemoryUserAccountRepository

runApp :: InMemoryUserAccountRepository a -> IO a
runApp = flip evalStateT Map.empty . runInMemory

main :: IO ()
main = do
  result <- runApp $ runExceptT $ do
    event1 <- createUserAccount "Alice" "[email protected]"
    case event1 of
      UserAccountCreated account -> do
        event2 <- updateUserAccountEmail (accountId account) "[email protected]"
        return [event1, event2]
      _ -> throwError "Unexpected event"

  case result of
    Left err -> putStrLn $ "Error: " ++ err
    Right events -> mapM_ print events