{-# 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)