{-# LANGUAGE Strict #-}

-- | Utilities for exception safe message boxes.
--
-- This provides a wrapper around "UnliftIO.MessageBox.Class" instances
-- to catch 'SomeException' in all methods like 'deliver' and 'receive'.
module UnliftIO.MessageBox.CatchAll
  ( CatchAllArg (..),
    CatchAllBox (..),
    CatchAllInput (..),
  )
where

import UnliftIO.MessageBox.Util.Future (Future (Future))
import UnliftIO.MessageBox.Class
  ( IsInput (..),
    IsMessageBox (..),
    IsMessageBoxArg (..),
  )
import UnliftIO (SomeException, liftIO, try)
import UnliftIO.Concurrent (threadDelay)

-- | A wrapper around values that are instances
-- of 'IsMessageBoxArg'. The factory wraps
-- the result of the delegated 'newMessageBox'
-- invocation into a 'CatchAllBox'.
newtype CatchAllArg cfg = CatchAllArg cfg
  deriving stock (CatchAllArg cfg -> CatchAllArg cfg -> Bool
(CatchAllArg cfg -> CatchAllArg cfg -> Bool)
-> (CatchAllArg cfg -> CatchAllArg cfg -> Bool)
-> Eq (CatchAllArg cfg)
forall cfg. Eq cfg => CatchAllArg cfg -> CatchAllArg cfg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CatchAllArg cfg -> CatchAllArg cfg -> Bool
$c/= :: forall cfg. Eq cfg => CatchAllArg cfg -> CatchAllArg cfg -> Bool
== :: CatchAllArg cfg -> CatchAllArg cfg -> Bool
$c== :: forall cfg. Eq cfg => CatchAllArg cfg -> CatchAllArg cfg -> Bool
Eq, Eq (CatchAllArg cfg)
Eq (CatchAllArg cfg)
-> (CatchAllArg cfg -> CatchAllArg cfg -> Ordering)
-> (CatchAllArg cfg -> CatchAllArg cfg -> Bool)
-> (CatchAllArg cfg -> CatchAllArg cfg -> Bool)
-> (CatchAllArg cfg -> CatchAllArg cfg -> Bool)
-> (CatchAllArg cfg -> CatchAllArg cfg -> Bool)
-> (CatchAllArg cfg -> CatchAllArg cfg -> CatchAllArg cfg)
-> (CatchAllArg cfg -> CatchAllArg cfg -> CatchAllArg cfg)
-> Ord (CatchAllArg cfg)
CatchAllArg cfg -> CatchAllArg cfg -> Bool
CatchAllArg cfg -> CatchAllArg cfg -> Ordering
CatchAllArg cfg -> CatchAllArg cfg -> CatchAllArg cfg
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall cfg. Ord cfg => Eq (CatchAllArg cfg)
forall cfg. Ord cfg => CatchAllArg cfg -> CatchAllArg cfg -> Bool
forall cfg.
Ord cfg =>
CatchAllArg cfg -> CatchAllArg cfg -> Ordering
forall cfg.
Ord cfg =>
CatchAllArg cfg -> CatchAllArg cfg -> CatchAllArg cfg
min :: CatchAllArg cfg -> CatchAllArg cfg -> CatchAllArg cfg
$cmin :: forall cfg.
Ord cfg =>
CatchAllArg cfg -> CatchAllArg cfg -> CatchAllArg cfg
max :: CatchAllArg cfg -> CatchAllArg cfg -> CatchAllArg cfg
$cmax :: forall cfg.
Ord cfg =>
CatchAllArg cfg -> CatchAllArg cfg -> CatchAllArg cfg
>= :: CatchAllArg cfg -> CatchAllArg cfg -> Bool
$c>= :: forall cfg. Ord cfg => CatchAllArg cfg -> CatchAllArg cfg -> Bool
> :: CatchAllArg cfg -> CatchAllArg cfg -> Bool
$c> :: forall cfg. Ord cfg => CatchAllArg cfg -> CatchAllArg cfg -> Bool
<= :: CatchAllArg cfg -> CatchAllArg cfg -> Bool
$c<= :: forall cfg. Ord cfg => CatchAllArg cfg -> CatchAllArg cfg -> Bool
< :: CatchAllArg cfg -> CatchAllArg cfg -> Bool
$c< :: forall cfg. Ord cfg => CatchAllArg cfg -> CatchAllArg cfg -> Bool
compare :: CatchAllArg cfg -> CatchAllArg cfg -> Ordering
$ccompare :: forall cfg.
Ord cfg =>
CatchAllArg cfg -> CatchAllArg cfg -> Ordering
$cp1Ord :: forall cfg. Ord cfg => Eq (CatchAllArg cfg)
Ord, Int -> CatchAllArg cfg -> ShowS
[CatchAllArg cfg] -> ShowS
CatchAllArg cfg -> String
(Int -> CatchAllArg cfg -> ShowS)
-> (CatchAllArg cfg -> String)
-> ([CatchAllArg cfg] -> ShowS)
-> Show (CatchAllArg cfg)
forall cfg. Show cfg => Int -> CatchAllArg cfg -> ShowS
forall cfg. Show cfg => [CatchAllArg cfg] -> ShowS
forall cfg. Show cfg => CatchAllArg cfg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CatchAllArg cfg] -> ShowS
$cshowList :: forall cfg. Show cfg => [CatchAllArg cfg] -> ShowS
show :: CatchAllArg cfg -> String
$cshow :: forall cfg. Show cfg => CatchAllArg cfg -> String
showsPrec :: Int -> CatchAllArg cfg -> ShowS
$cshowsPrec :: forall cfg. Show cfg => Int -> CatchAllArg cfg -> ShowS
Show)

-- | A wrapper around values that are instances
-- of 'IsMessageBox'.
--
-- The 'Input' type will be wrapped using
-- 'CatchAllInput'.
newtype CatchAllBox box a = CatchAllBox (box a)

-- | A wrapper around values that are instances
-- of 'IsInput'.
newtype CatchAllInput i a = CatchAllInput (i a)

instance IsMessageBoxArg cfg => IsMessageBoxArg (CatchAllArg cfg) where
  type MessageBox (CatchAllArg cfg) = CatchAllBox (MessageBox cfg)
  {-# INLINE newMessageBox #-}
  newMessageBox :: CatchAllArg cfg -> m (MessageBox (CatchAllArg cfg) a)
newMessageBox (CatchAllArg !cfg
cfg) = MessageBox cfg a -> CatchAllBox (MessageBox cfg) a
forall k (box :: k -> *) (a :: k). box a -> CatchAllBox box a
CatchAllBox (MessageBox cfg a -> CatchAllBox (MessageBox cfg) a)
-> m (MessageBox cfg a) -> m (CatchAllBox (MessageBox cfg) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> cfg -> m (MessageBox cfg a)
forall argument (m :: * -> *) a.
(IsMessageBoxArg argument, MonadUnliftIO m) =>
argument -> m (MessageBox argument a)
newMessageBox cfg
cfg
  getConfiguredMessageLimit :: CatchAllArg cfg -> Maybe Int
getConfiguredMessageLimit (CatchAllArg !cfg
cfg) =
    cfg -> Maybe Int
forall argument. IsMessageBoxArg argument => argument -> Maybe Int
getConfiguredMessageLimit cfg
cfg

instance IsMessageBox box => IsMessageBox (CatchAllBox box) where
  type Input (CatchAllBox box) = CatchAllInput (Input box)
  {-# INLINE newInput #-}
  newInput :: CatchAllBox box a -> m (Input (CatchAllBox box) a)
newInput (CatchAllBox !box a
b) =
    Input box a -> CatchAllInput (Input box) a
forall k (i :: k -> *) (a :: k). i a -> CatchAllInput i a
CatchAllInput (Input box a -> CatchAllInput (Input box) a)
-> m (Input box a) -> m (CatchAllInput (Input box) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> box a -> m (Input box a)
forall (box :: * -> *) (m :: * -> *) a.
(IsMessageBox box, MonadUnliftIO m) =>
box a -> m (Input box a)
newInput box a
b
  {-# INLINE receive #-}
  receive :: CatchAllBox box a -> m (Maybe a)
receive (CatchAllBox !box a
box) =
    m (Maybe a) -> m (Either SomeException (Maybe a))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException
      (box a -> m (Maybe a)
forall (box :: * -> *) (m :: * -> *) a.
(IsMessageBox box, MonadUnliftIO m) =>
box a -> m (Maybe a)
receive box a
box)
      m (Either SomeException (Maybe a))
-> (Either SomeException (Maybe a) -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
_e -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
_e) m () -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Right Maybe a
r -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
r
  {-# INLINE receiveAfter #-}
  -- | Call the wrapped 'receiveAfter' and catch all sync exceptions.
  -- 
  -- When an exception is caught return 'Nothing'.
  receiveAfter :: CatchAllBox box a -> Int -> m (Maybe a)
receiveAfter (CatchAllBox !box a
box) !Int
t =
    m (Maybe a) -> m (Either SomeException (Maybe a))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException
      (box a -> Int -> m (Maybe a)
forall (box :: * -> *) (m :: * -> *) a.
(IsMessageBox box, MonadUnliftIO m) =>
box a -> Int -> m (Maybe a)
receiveAfter box a
box Int
t)
      m (Either SomeException (Maybe a))
-> (Either SomeException (Maybe a) -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
_e -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
_e) m () -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        Right Maybe a
r -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
r
  {-# INLINE tryReceive #-}
  tryReceive :: CatchAllBox box a -> m (Future a)
tryReceive (CatchAllBox !box a
box) =
    m (Future a) -> m (Either SomeException (Future a))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException
      (box a -> m (Future a)
forall (box :: * -> *) (m :: * -> *) a.
(IsMessageBox box, MonadUnliftIO m) =>
box a -> m (Future a)
tryReceive box a
box)
      m (Either SomeException (Future a))
-> (Either SomeException (Future a) -> m (Future a))
-> m (Future a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
_e ->
          IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
_e)
            m () -> m (Future a) -> m (Future a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Future a -> m (Future a)
forall (m :: * -> *) a. Monad m => a -> m a
return
              ( IO (Maybe a) -> Future a
forall a. IO (Maybe a) -> Future a
Future
                  ( do
                      -- suspense...
                      Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
1000
                      -- ... anyway, the truth is: there is no spoon.
                      Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                  )
              )
        Right Future a
r -> Future a -> m (Future a)
forall (m :: * -> *) a. Monad m => a -> m a
return Future a
r

instance (IsInput i) => IsInput (CatchAllInput i) where
  {-# INLINE deliver #-}
  deliver :: CatchAllInput i a -> a -> m Bool
deliver (CatchAllInput !i a
i) !a
msg =
    m Bool -> m (Either SomeException Bool)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try @_ @SomeException
      (i a -> a -> m Bool
forall (input :: * -> *) (m :: * -> *) a.
(IsInput input, MonadUnliftIO m) =>
input a -> a -> m Bool
deliver i a
i a
msg)
      m (Either SomeException Bool)
-> (Either SomeException Bool -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
_e -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
_e) m () -> m Bool -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Right Bool
r -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
r