{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveFunctor #-} module Util.IOExtra ( requireM , tryAndLogIO , tryAndLogAll , catchAndLogIO , catchAndLogAll , onExceptionLog , bracketOnErrorLog , handleAndLogAll , catchAndLog , handleAndLog , logWarnStr , logInfoStr , logErrorStr , logAndThrow , logInfoShow , logErrorShow , throwLeftM , throwNothingM , ErrMsg(..) , OneBillionDollarBug(..) , module X ) where import Control.Monad as X ( unless, void, when ) import Data.Maybe as X ( fromJust, isJust ) import Control.Exception as X ( AssertionFailed(..) , Exception(..) , SomeException(..) ) import Control.Monad.Catch as X import Control.Monad.IO.Class as X import Control.Monad.Logger as X ( LoggingT , MonadLogger , MonadLoggerIO , logErrorCS , logInfoCS , logWarnCS , runLoggingT ) import Control.Monad.Logger.CallStack as X ( logError, logInfo ) import Control.Monad.Trans.Control as X import Control.Monad.Trans.Resource as X import Control.Concurrent.Lifted as X import Control.Concurrent.Async.Lifted as X import Text.Printf as X import Data.Text ( Text, pack ) import GHC.Stack requireM :: (HasCallStack, MonadCatch m, MonadLogger m) => String -> Bool -> m () requireM :: String -> Bool -> m () requireM = CallStack -> String -> Bool -> m () forall (m :: * -> *). (MonadCatch m, MonadLogger m) => CallStack -> String -> Bool -> m () requireMCS CallStack HasCallStack => CallStack callStack requireMCS :: (MonadCatch m, MonadLogger m) => CallStack -> String -> Bool -> m () requireMCS :: CallStack -> String -> Bool -> m () requireMCS CallStack cs String title Bool predicate = let e :: AssertionFailed e = String -> AssertionFailed AssertionFailed String title in Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool predicate ((CallStack -> Text -> m ()) -> CallStack -> ErrMsg AssertionFailed -> m () forall s (m :: * -> *). Show s => (CallStack -> Text -> m ()) -> CallStack -> s -> m () logShow CallStack -> Text -> m () forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m () logErrorCS CallStack cs (String -> AssertionFailed -> ErrMsg AssertionFailed forall a. String -> a -> ErrMsg a ErrMsg String title AssertionFailed e) m () -> m () -> m () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> AssertionFailed -> m () forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwM AssertionFailed e) catchAndLogIO :: (HasCallStack, MonadCatch m, MonadLogger m) => m a -> (IOError -> m a) -> m a catchAndLogIO :: m a -> (IOError -> m a) -> m a catchAndLogIO = m a -> (IOError -> m a) -> m a forall (m :: * -> *) e a. (HasCallStack, MonadCatch m, MonadLogger m, Exception e) => m a -> (e -> m a) -> m a catchAndLog catchAndLogAll :: (HasCallStack, MonadCatch m, MonadLogger m) => m a -> (SomeException -> m a) -> m a catchAndLogAll :: m a -> (SomeException -> m a) -> m a catchAndLogAll = m a -> (SomeException -> m a) -> m a forall (m :: * -> *) e a. (HasCallStack, MonadCatch m, MonadLogger m, Exception e) => m a -> (e -> m a) -> m a catchAndLog bracketOnErrorLog :: (HasCallStack, MonadMask m, MonadLogger m) => m a -> (a -> m b) -> (a -> m c) -> m c bracketOnErrorLog :: m a -> (a -> m b) -> (a -> m c) -> m c bracketOnErrorLog m a acquire a -> m b emergencyCleanup a -> m c use = ((forall a. m a -> m a) -> m c) -> m c forall (m :: * -> *) b. MonadMask m => ((forall a. m a -> m a) -> m b) -> m b mask (((forall a. m a -> m a) -> m c) -> m c) -> ((forall a. m a -> m a) -> m c) -> m c forall a b. (a -> b) -> a -> b $ \forall a. m a -> m a unmasked -> do a resource <- m a acquire m c -> m c forall a. m a -> m a unmasked (a -> m c use a resource) m c -> m b -> m c forall (m :: * -> *) a b. (HasCallStack, MonadCatch m, MonadLogger m) => m a -> m b -> m a `onExceptionLog` a -> m b emergencyCleanup a resource onExceptionLog :: (HasCallStack, MonadCatch m, MonadLogger m) => m a -> m b -> m a onExceptionLog :: m a -> m b -> m a onExceptionLog m a action m b handler = m a action m a -> (SomeException -> m a) -> m a forall (m :: * -> *) a. (HasCallStack, MonadCatch m, MonadLogger m) => m a -> (SomeException -> m a) -> m a `catchAndLogAll` SomeException -> m a forall e b. Exception e => e -> m b handler' where handler' :: e -> m b handler' e e = m b -> m () forall (f :: * -> *) a. Functor f => f a -> f () void m b handler m () -> m b -> m b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> e -> m b forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwM e e handleAndLogAll :: (HasCallStack, MonadCatch m, MonadLogger m) => (SomeException -> m a) -> m a -> m a handleAndLogAll :: (SomeException -> m a) -> m a -> m a handleAndLogAll = (SomeException -> m a) -> m a -> m a forall (m :: * -> *) e a. (HasCallStack, MonadCatch m, MonadLogger m, Exception e) => (e -> m a) -> m a -> m a handleAndLog logWarnStr :: (HasCallStack, MonadLogger m) => String -> m () logWarnStr :: String -> m () logWarnStr = CallStack -> Text -> m () forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m () logWarnCS CallStack HasCallStack => CallStack callStack (Text -> m ()) -> (String -> Text) -> String -> m () forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Text pack logInfoStr :: (HasCallStack, MonadLogger m) => String -> m () logInfoStr :: String -> m () logInfoStr = CallStack -> Text -> m () forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m () logInfoCS CallStack HasCallStack => CallStack callStack (Text -> m ()) -> (String -> Text) -> String -> m () forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Text pack logErrorStr :: (HasCallStack, MonadLogger m) => String -> m () logErrorStr :: String -> m () logErrorStr = CallStack -> Text -> m () forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m () logErrorCS CallStack HasCallStack => CallStack callStack (Text -> m ()) -> (String -> Text) -> String -> m () forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Text pack catchAndLog :: (HasCallStack, MonadCatch m, MonadLogger m, Exception e) => m a -> (e -> m a) -> m a catchAndLog :: m a -> (e -> m a) -> m a catchAndLog m a action e -> m a handler = (e -> m a) -> m a -> m a forall (m :: * -> *) e a. (MonadCatch m, Exception e) => (e -> m a) -> m a -> m a handle (\e e -> CallStack -> Text -> m () forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m () logErrorCS CallStack HasCallStack => CallStack callStack (String -> Text pack (String -> Text) -> String -> Text forall a b. (a -> b) -> a -> b $ e -> String forall e. Exception e => e -> String displayException e e) m () -> m a -> m a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> e -> m a handler e e) m a action handleAndLog :: (HasCallStack, MonadCatch m, MonadLogger m, Exception e) => (e -> m a) -> m a -> m a handleAndLog :: (e -> m a) -> m a -> m a handleAndLog = (m a -> (e -> m a) -> m a) -> (e -> m a) -> m a -> m a forall a b c. (a -> b -> c) -> b -> a -> c flip m a -> (e -> m a) -> m a forall (m :: * -> *) e a. (HasCallStack, MonadCatch m, MonadLogger m, Exception e) => m a -> (e -> m a) -> m a catchAndLog tryAndLogIO :: (HasCallStack, MonadCatch m, MonadLogger m) => m a -> m (Maybe a) tryAndLogIO :: m a -> m (Maybe a) tryAndLogIO = (m (Maybe a) -> (IOError -> m (Maybe a)) -> m (Maybe a)) -> (IOError -> m (Maybe a)) -> m (Maybe a) -> m (Maybe a) forall a b c. (a -> b -> c) -> b -> a -> c flip m (Maybe a) -> (IOError -> m (Maybe a)) -> m (Maybe a) forall (m :: * -> *) a. (HasCallStack, MonadCatch m, MonadLogger m) => m a -> (IOError -> m a) -> m a catchAndLogIO (m (Maybe a) -> IOError -> m (Maybe a) forall a b. a -> b -> a const (Maybe a -> m (Maybe a) forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe a forall a. Maybe a Nothing)) (m (Maybe a) -> m (Maybe a)) -> (m a -> m (Maybe a)) -> m a -> m (Maybe a) forall b c a. (b -> c) -> (a -> b) -> a -> c . (a -> Maybe a) -> m a -> m (Maybe a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> Maybe a forall a. a -> Maybe a Just tryAndLogAll :: forall a m. (HasCallStack, MonadCatch m, MonadLogger m) => m a -> m (Maybe a) tryAndLogAll :: m a -> m (Maybe a) tryAndLogAll = (m (Maybe a) -> (SomeException -> m (Maybe a)) -> m (Maybe a)) -> (SomeException -> m (Maybe a)) -> m (Maybe a) -> m (Maybe a) forall a b c. (a -> b -> c) -> b -> a -> c flip m (Maybe a) -> (SomeException -> m (Maybe a)) -> m (Maybe a) forall (m :: * -> *) e a. (HasCallStack, MonadCatch m, MonadLogger m, Exception e) => m a -> (e -> m a) -> m a catchAndLog (m (Maybe a) -> SomeException -> m (Maybe a) forall a b. a -> b -> a const (Maybe a -> m (Maybe a) forall (m :: * -> *) a. Monad m => a -> m a return Maybe a forall a. Maybe a Nothing) :: SomeException -> m (Maybe a)) (m (Maybe a) -> m (Maybe a)) -> (m a -> m (Maybe a)) -> m a -> m (Maybe a) forall b c a. (b -> c) -> (a -> b) -> a -> c . (a -> Maybe a) -> m a -> m (Maybe a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap a -> Maybe a forall a. a -> Maybe a Just logAndThrow :: (HasCallStack, MonadMask m, MonadLogger m, Exception e) => e -> m a logAndThrow :: e -> m a logAndThrow e e = (CallStack -> Text -> m ()) -> CallStack -> e -> m () forall s (m :: * -> *). Show s => (CallStack -> Text -> m ()) -> CallStack -> s -> m () logShow CallStack -> Text -> m () forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m () logErrorCS CallStack HasCallStack => CallStack callStack e e m () -> m a -> m a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> e -> m a forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwM e e logShow :: (Show s) => (CallStack -> Text -> m ()) -> CallStack -> s -> m () logShow :: (CallStack -> Text -> m ()) -> CallStack -> s -> m () logShow CallStack -> Text -> m () f CallStack cs = CallStack -> Text -> m () f CallStack cs (Text -> m ()) -> (s -> Text) -> s -> m () forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Text pack (String -> Text) -> (s -> String) -> s -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . s -> String forall a. Show a => a -> String show logInfoShow :: (HasCallStack, Show s, MonadLogger m) => s -> m () logInfoShow :: s -> m () logInfoShow = (CallStack -> Text -> m ()) -> CallStack -> s -> m () forall s (m :: * -> *). Show s => (CallStack -> Text -> m ()) -> CallStack -> s -> m () logShow CallStack -> Text -> m () forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m () logInfoCS CallStack HasCallStack => CallStack callStack logErrorShow :: (HasCallStack, Show s, MonadLogger m) => s -> m () logErrorShow :: s -> m () logErrorShow = (CallStack -> Text -> m ()) -> CallStack -> s -> m () forall s (m :: * -> *). Show s => (CallStack -> Text -> m ()) -> CallStack -> s -> m () logShow CallStack -> Text -> m () forall (m :: * -> *). MonadLogger m => CallStack -> Text -> m () logErrorCS CallStack HasCallStack => CallStack callStack throwLeftM :: (HasCallStack, MonadMask m, MonadLogger m, Exception e) => m (Either e r) -> m r throwLeftM :: m (Either e r) -> m r throwLeftM = (m (Either e r) -> (Either e r -> m r) -> m r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (e -> m r) -> (r -> m r) -> Either e r -> m r forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either e -> m r forall (m :: * -> *) e a. (HasCallStack, MonadMask m, MonadLogger m, Exception e) => e -> m a logAndThrow r -> m r forall (m :: * -> *) a. Monad m => a -> m a return) throwNothingM :: (HasCallStack, MonadLogger m, MonadCatch m) => m (Maybe r) -> m r throwNothingM :: m (Maybe r) -> m r throwNothingM m (Maybe r) mmr = do Maybe r mr <- m (Maybe r) mmr CallStack -> String -> Bool -> m () forall (m :: * -> *). (MonadCatch m, MonadLogger m) => CallStack -> String -> Bool -> m () requireMCS CallStack HasCallStack => CallStack callStack (OneBillionDollarBug -> String forall a. Show a => a -> String show OneBillionDollarBug OneBillionDollarBug) (Maybe r -> Bool forall a. Maybe a -> Bool isJust Maybe r mr) r -> m r forall (m :: * -> *) a. Monad m => a -> m a return (Maybe r -> r forall a. HasCallStack => Maybe a -> a fromJust Maybe r mr) data OneBillionDollarBug = OneBillionDollarBug deriving Int -> OneBillionDollarBug -> ShowS [OneBillionDollarBug] -> ShowS OneBillionDollarBug -> String (Int -> OneBillionDollarBug -> ShowS) -> (OneBillionDollarBug -> String) -> ([OneBillionDollarBug] -> ShowS) -> Show OneBillionDollarBug forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [OneBillionDollarBug] -> ShowS $cshowList :: [OneBillionDollarBug] -> ShowS show :: OneBillionDollarBug -> String $cshow :: OneBillionDollarBug -> String showsPrec :: Int -> OneBillionDollarBug -> ShowS $cshowsPrec :: Int -> OneBillionDollarBug -> ShowS Show instance Exception OneBillionDollarBug data ErrMsg a = ErrMsg String a instance Show a => Show (ErrMsg a) where show :: ErrMsg a -> String show (ErrMsg String title a a) = String title String -> ShowS forall a. [a] -> [a] -> [a] ++ String ": " String -> ShowS forall a. [a] -> [a] -> [a] ++ a -> String forall a. Show a => a -> String show a a instance Exception a => Exception (ErrMsg a)