Error handling with variants

oops.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Main where

import Control.Monad.Except
import Control.Monad.Identity
import Data.Bifunctor
import Data.Variant

newtype Username = Username String deriving Show
newtype Filename = Filename String deriving Show

newtype User = User Username deriving Show
newtype File = File Filename deriving Show

data UserError = UserNotFound deriving Show
data FileError = FileNotFound deriving Show

throwErr :: e' `CouldBe` e => Either e a -> Either (Variant e') a
throwErr = first throw

removeVariant :: Either (Variant '[e]) a -> Either e a
removeVariant = first (flip case_ id)

getUser :: Username -> Either UserError User
getUser = Right . User

getFile :: Filename -> Either FileError File
getFile _ = Left FileNotFound

getBoth
  :: (e `CouldBe` UserError, e `CouldBe` FileError)
  => Username -> Filename -> Either (Variant e) (User, File)
getBoth username filename = do
  file <- throwErr $ getFile filename
  user <- throwErr $ getUser username
  return (user, file)

handleFileErr
  :: e `CouldBe` UserError
  => Username -> Filename -> ExceptT (Variant e) Identity (User, File)
handleFileErr username filename = do
  let getBoth' = ExceptT $ pure $ getBoth username filename
  (user, file) <- catchM @FileError getBoth'
                $ \_ -> pure (User username, File filename)
  return (user, file)

main :: IO ()
main = do
  let r = removeVariant $ runIdentity $ runExceptT
        $ handleFileErr @'[UserError] (Username "user") (Filename "file")
  case r of
    Left err           -> print err
    Right (user, file) -> putStrLn $ show user ++ " " ++ show file
  case (getBoth @'[UserError, FileError]
                (Username "user")
                (Filename "file")) of
    Left err -> case_ err
      (\userErr -> putStrLn $ "User error: " ++ show userErr)
      (\fileErr -> putStrLn $ "File error: " ++ show fileErr)
    Right (user, file) -> putStrLn $ show user ++ " " ++ show file